modmain.bas

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

Attribute VB_Name = "ModMain"
Option Explicit
Const ScrCopy = &HCC0020
Enum FoxFlags
    BAD = &H1
    GOOD = &H3
End Enum
Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Public 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
Public Declare Function RedrawWindow Lib "user32" (ByVal hwnd As Long, lprcUpdate As Long, ByVal hrgnUpdate As Long, ByVal fuRedraw As Long) As Long
Public 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
Public 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
Public Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Public Declare Function GetTextColor Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Public Declare Function MoveToEx Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, lpPoint As Any) As Long
Public Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Public 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
Public Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Public 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
Public 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
Public Declare Function timeGetTime Lib "winmm.dll" () As Long

Public HandPen As Long
Public OldPen As Long


Public IsPlaying As Boolean
Public Function MainSub(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)
    If IsPlaying Then Exit Function
    Static SaveAng 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
    IsPlaying = True
    Do
        While Not IsPlaying     'Pause
            DoEvents
        Wend
        '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 Exit For
               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
               
               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 Exit For
               KT = timeGetTime()
               Obj.Line (320 - Ang, 0)-(321 + Ang, 480), &HFF0000, B
               
               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 SaveAng = Ang: Exit For
                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
                
                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 Exit For
                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)
                
                DoEvents
                While timeGetTime - KT < 10
                    DoEvents
                Wend
            Next Ang
            Call DelayTime(1000)
    Loop
IsPlaying = False
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