moddemosky.bas

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

Attribute VB_Name = "ModDemoSky"
Option Explicit
Const ScrCopy = &HCC0020
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 IsDemoPlaying As Boolean
Private IsINSTART As Boolean '用来判断过程是否已经在运行，不允许被外部更改
Public Function StartDemoPlay(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 IsUnloadAll Then Exit Function
    If IsDemoPlaying Then Exit Function
    If IsINSTART Then Exit Function
    Static LtoR As Integer
    Dim Wid As Long
    Dim Hei As Long
    Dim Ang As Long
    Dim KT As Long
    Dim DT As Long
    Dim CurColor As Long
    Dim ForeHdc As Long
    IsDemoPlaying = True
    IsINSTART = True    '用来判断该过程是否已经在运行，不允许被外部更改
    Do While IsDemoPlaying
        
            Wid = 0
            Hei = 0
            KT = 0
            Obj.DrawMode = 13
            LtoR = Sgn((LtoR + 1) Mod 2 - Sgn(LtoR) * 0.5)
           For Ang = 0 To Times * 360 * LtoR Step StepAngle * LtoR
               If Not IsDemoPlaying Then Exit Do
               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 = LtoR * Height * Ang / 360 / Times
               If Wid < Width Then Wid = LtoR * Width * Ang / 360 / Times
               
               If Hei > Height Then Hei = Height      '此处不能用elseif 代替
               If Wid > Width Then Wid = Width
               DoEvents
               While IsDemoPlaying And Abs(timeGetTime - KT) < 35
                   DoEvents
               Wend
            Next Ang
            
            Obj.DrawMode = 7
            Call DelayDemoTime(1000)
            For Ang = 0 To 320
                If Not IsDemoPlaying Then Exit Do
               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 IsDemoPlaying And Abs(timeGetTime - KT) < 10
                    DoEvents
               Wend
            Next Ang
            
            Obj.DrawMode = 13
            ObjBack.DrawMode = 7
            CurColor = GetPixel(hdcShow, 10, 10)
            Call DelayDemoTime(1000)
            For Ang = 0 To ObjBack.ScaleWidth - 1
                If Not IsDemoPlaying Then Exit Do
                KT = timeGetTime()
                'If SaveAng <> 0 Then Ang = SaveAng: SaveAng = 0
                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 IsDemoPlaying And Abs(timeGetTime - KT) < 10
                    DoEvents
                Wend
            Next Ang
            
            Obj.DrawMode = 13
            ObjBack.DrawMode = 7
            Call DelayDemoTime(500)
            For Ang = 1 To 640 Step 2
                If Not IsDemoPlaying Then Exit Do
                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 IsDemoPlaying And Abs(timeGetTime - KT) < 10
                    DoEvents
                Wend
            Next Ang
            
            Obj.DrawMode = 13
            ObjBack.DrawMode = 13
            Call DelayDemoTime(500)
            For Ang = 0 To 640 '实际为639
                If Not IsDemoPlaying Then Exit Do
                KT = timeGetTime()
                Obj.Line (Ang, -80)-(-1, Ang - 79), BackColor
                Obj.Line (640 - Ang, 560)-(640, 560 - Ang), BackColor
                Obj.Line (0, 560 - Ang)-(Ang, 560), BackColor
                Obj.Line (640 - Ang, -80)-(640, Ang - 80), BackColor
                BitBlt GetDC(0), 0, 0, 640, 480, hdcShow, 0, 0, vbSrcCopy
                
                DoEvents
                While IsDemoPlaying And Abs(timeGetTime - KT) < 10
                    DoEvents
                Wend
            Next Ang
            Call DelayDemoTime(1000)
    Loop
InvalidateRect 0, 0, 0
IsINSTART = False
End Function
Private Sub DelayDemoTime(ByVal DelayT As Long)
Dim DT As Long
    DT = timeGetTime()
    While IsDemoPlaying And Abs(timeGetTime - DT) < DelayT
        DoEvents
    Wend
End Sub

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