clsstart.cls

一款飞机射击游戏的源代码

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "ClsStart"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit
Const ScrCopy = &HCC0020
Enum FoxFlags
    BAD = &H1
    GOOD = &H3
End Enum
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, lpRect As Long, ByVal bErase As Long) As Long
Private Declare Function RedrawWindow Lib "user32" (ByVal hwnd As Long, lprcUpdate As Long, ByVal hrgnUpdate As Long, ByVal fuRedraw As Long) 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 TextOut Lib "gdi32" Alias "TextOutA" (ByVal Hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Private Declare Function Rectangle Lib "gdi32" (ByVal Hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function SetTextColor Lib "gdi32" (ByVal Hdc As Long, ByVal crColor As Long) As Long
Private Declare Function GetTextColor Lib "gdi32" (ByVal Hdc As Long) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal Hdc As Long, ByVal hObject As Long) As Long
Private Declare Function MoveToEx Lib "gdi32" (ByVal Hdc As Long, ByVal X As Long, ByVal Y As Long, lpPoint As Any) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal Hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal Hdc 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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal Hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function FoxRotate Lib "Rot.Ms" (ByVal Hdc 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 Angle As Double, Optional ByVal MaskColor As Long, Optional ByVal Flags As FoxFlags) As Long
Private Declare Function FoxHSL Lib "Rot.Ms" (ByVal Hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hScrDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal Hue As Single, ByVal Saturation As Single, ByVal Lightness As Single, Optional ByVal MaskColor As Long, Optional ByVal Flags As Long) As Long
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Private HandPen As Long
Private OldPen As Long
Private IsPlaying As Boolean
Private IsINSTART As Boolean '用来判断过程是否已经在运行，不允许被外部更改

Public Function StartPlay(ByVal ParentObj As Object, ByVal Obj As Object, ByVal ObjBack As Object, ByVal hdcShow As Long, ByVal hdcShowSave As Long, ByVal hdcBuf As Long, ByVal hdcBack As Long, ByVal Sx As Long, ByVal Sy As Long, ByVal Width As Single, ByVal Height As Single, ByVal MaskColor As Long, ByVal BackColor As Long, ByVal StepAngle As Long, Optional ByVal Times As Long = 1)
On Error Resume Next
    If IsPlaying Then Exit Function
    If IsINSTART Then Exit Function
    'Static SaveAng As Long
    Static WL As Long
    Static LorR As Integer
    Dim Wid As Long
    Dim Hei As Long
    Dim Ang As Long
    Dim KT As Long
    Dim DT As Long
    Dim RunTimes As Long
    Dim CurColor As Long
    Dim ForeHdc As Long
    IsPlaying = True
    IsINSTART = True    '用来判断该过程是否已经在运行，不允许被外部更改
    WL = IIf(WL = 0, ParentObj.hwnd, WL)
    Do While IsPlaying And (ParentObj.hwnd = WL)
        RunTimes = RunTimes + 1
        
            Wid = 0
            Hei = 0
            KT = 0
            Obj.DrawMode = 13
            LorR = Sgn((LorR + 1) Mod 2 - Sgn(LorR) * 0.5)
           For Ang = 0 To Times * 360 * LorR Step StepAngle * LorR
               If Not IsPlaying Then GoTo EX
               KT = timeGetTime()
               Obj.Line (0, 0)-(640, 480), BackColor, BF
               StretchBlt hdcBuf, 0, 0, Wid, Hei, hdcBack, 0, 0, Width, Height, ScrCopy
               FoxRotate hdcShow, Sx, Sy, Wid, Hei, hdcBuf, 0, 0, Ang, MaskColor, BAD
               BitBlt GetDC(0), 0, 0, 640, 480, hdcShow, 0, 0, vbSrcCopy
               
               If Hei < Height Then Hei = LorR * Height * Ang / 360 / Times
               If Wid < Width Then Wid = LorR * Width * Ang / 360 / Times
               
               If Hei > Height Then Hei = Height      '此处不能用elseif 代替
               If Wid > Width Then Wid = Width
               DoEvents
               While timeGetTime - KT < 35
                   DoEvents
               Wend
            Next Ang
            
            Call DelayTime(1000)
            
            Obj.DrawMode = 7
            For Ang = 0 To 320
                If Not IsPlaying Then GoTo EX
               KT = timeGetTime()
               Obj.Line (320 - Ang, 0)-(321 + Ang, 480), &HFF0000, B
               BitBlt GetDC(0), 0, 0, 640, 480, hdcShow, 0, 0, vbSrcCopy
               
               DoEvents
               While timeGetTime - KT < 10
                    DoEvents
               Wend
            Next Ang
            
            Call DelayTime(1000)
            
            Obj.DrawMode = 13
            ObjBack.DrawMode = 7
            CurColor = GetPixel(hdcShow, 10, 10)
            For Ang = 0 To ObjBack.ScaleWidth - 1
                If Not IsPlaying Then GoTo EX
                'If SaveAng <> 0 Then Ang = SaveAng: SaveAng = 0
                KT = timeGetTime()
                Obj.Line (Sx - Width \ 2 - 1, Sy - Height \ 2 - 1)-(Sx + Width \ 2 + 1, Sy + Height \ 2 + 1), CurColor, BF
                
                ObjBack.Line (Ang, 0)-(Ang, ObjBack.Height), &HFF00FF
                ObjBack.Line (ObjBack.ScaleWidth - 1 - Ang, 0)-(ObjBack.ScaleWidth - 1 - Ang, Obj.ScaleHeight), &HFF00FF
                FoxHSL hdcShow, Sx - Width \ 2, Sy - Height \ 2, Width, Height, hdcBack, 0, 0, timeGetTime / 30, 1, 0, , 1
                BitBlt GetDC(0), 0, 0, 640, 480, hdcShow, 0, 0, vbSrcCopy
                
                DoEvents
                While timeGetTime - KT < 10
                    DoEvents
                Wend
            Next Ang
            
            Call DelayTime(500)
            
            Obj.DrawMode = 13
            ObjBack.DrawMode = 7
            For Ang = 1 To 640 Step 2
                If Not IsPlaying Then GoTo EX
                KT = timeGetTime()
                Obj.Line (640 - Ang, -80)-(640, Ang - 80), &HFF8080, B
                Obj.Line (-1, 560 - Ang)-(Ang, 560), &HFF8080, B
                BitBlt GetDC(0), 0, 0, 640, 480, hdcShow, 0, 0, vbSrcCopy
                
                DoEvents
                While timeGetTime - KT < 10
                    DoEvents
                Wend
            Next Ang
            
            Call DelayTime(500)
            
            Obj.DrawMode = 13
            ObjBack.DrawMode = 13
            For Ang = 0 To 640 '实际为639
                If Not IsPlaying Then GoTo EX
                KT = timeGetTime()
                Obj.Line (Ang, -80)-(-1, Ang - 79)
                Obj.Line (640 - Ang, 560)-(640, 560 - Ang)
                Obj.Line (0, 560 - Ang)-(Ang, 560)
                Obj.Line (640 - Ang, -80)-(640, Ang - 80)
                BitBlt GetDC(0), 0, 0, 640, 480, hdcShow, 0, 0, vbSrcCopy
                
                DoEvents
                While timeGetTime - KT < 10
                    DoEvents
                Wend
            Next Ang
            Call DelayTime(1000)
    Loop
EX:
    Obj.Picture = Nothing
    ObjBack.Picture = Nothing
    ParentObj.Refresh
    InvalidateRect 0, 0, 0
    IsPlaying = False
    IsINSTART = False
On Error Resume Next
    If ParentObj.hwnd <> WL Then Unload ParentObj
End Function
Public Sub DelayTime(ByVal DelayT As Long)
Dim DT As Long
    DT = timeGetTime()
    While timeGetTime - DT < DelayT
        If Not IsPlaying Then Exit Sub
        DoEvents
    Wend
End Sub

Public Function StopPlay() As Boolean
    IsPlaying = False
    StopPlay = IsINSTART        '注意并不能实时返回
End Function

Private Sub Class_Terminate()
    IsPlaying = False
End Sub