moddrawextention.bas

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

Attribute VB_Name = "ModDrawExtention"
Option Explicit
Public M As Long
Type PixelXY
    X As Integer    '用作标志变量
    Y As Integer
    Speed As Byte
End Type
Type RunBulletTail
    X1 As Integer
    Y1 As Integer
    X2 As Integer
    Y2 As Integer
    CurFps As Byte
    ColorTail As Long   '用作标志变量
    DownColorBit As Byte
    DownColorPercent As Byte
End Type
Type TailBomb       '用于画圆的拖尾炸弹,该项两用
    WhichPla As Byte    '用作标志变量
    X As Single
    Y As Single
    SpeedX As Single
    SpeedY As Single
    StyleBomb As Byte
    CurFps As Byte
    ColorTail As Long
End Type
Type RunRandomPic
    HdcL As Long
    Width As Integer
    Height As Integer
End Type
Type Score
    TName As Long
    TScore As Long      '10 str
    'TTime As String * 20
End Type

Public ScoreP(1 To 2) As Long
Public CurMaxScore As Long
Public MaxMaxScore As Long

Public IsBomb(1 To 2) As Boolean
Public BombStarted(1 To 2) As Boolean
Public IsTailBombStart As Boolean

Private BombSeatX As Single
Private BombSeatY As Single
Private BombSeatR As Single
Private BombColour As Long
Private BombPla As Byte

Public hBrush As Long

Public IsShowScore As Boolean
Private FlashPr(1 To 2) As Byte

Private ScoreStr(1 To 17) As String
Public MScoreStr As Score
Public LoadHighScore As Long
Public PlayName(1 To 2) As String '* 16'只要16
Private CurPauseFps As Byte

Public Sub DrawText()
Dim S As String
Dim SLen As Byte
SetTextColor HdcViewBuf, vbWhite

If Not IsLoadP(1) Then
    If CurContinueAll = 1 Then S = "Game Over" Else S = "Press F2"
    FlashPr(1) = (FlashPr(1) + 1) Mod 20
    If FlashPr(1) > 10 Then S = ""
Else
    S = Format(ScoreP(1), "0000000") ' "ABCDLSKJDKLSADJLKSDAKLFJSDF"
End If
SetTextAlign HdcViewBuf, TA_LEFT Or TA_TOP Or TA_NOUPDATECP
If ScoreP(1) > ScoreP(2) Then SetTextColor HdcViewBuf, vbRed
Call TextOut(HdcViewBuf, MaxLeft + LR, 20, S, Len(S))
SetTextColor HdcViewBuf, vbYellow
Call TextOut(HdcViewBuf, MaxLeft + LR + 10, 10, "P1=" & CurContinueP(1) - 1, 5)

SetTextColor HdcViewBuf, vbWhite

If Not IsLoadP(2) Then
    If CurContinueAll = 1 Then S = "Game Over" Else S = "Press F3"
    FlashPr(2) = (FlashPr(2) + 1) Mod 20
    If FlashPr(2) > 10 Then S = ""
Else
    S = Format(ScoreP(2), "0000000")
End If
SetTextAlign HdcViewBuf, TA_RIGHT Or TA_TOP Or TA_NOUPDATECP
If ScoreP(2) > ScoreP(1) Then SetTextColor HdcViewBuf, vbRed
Call TextOut(HdcViewBuf, MaxRight + LR, 20, S, Len(S))
SetTextColor HdcViewBuf, vbYellow
Call TextOut(HdcViewBuf, MaxRight + LR - 10, 10, "P2=" & CurContinueP(2) - 1, 5)

    With MScoreStr
        If ScoreP(1) >= ScoreP(2) And ScoreP(1) > 0 Then
            .TScore = ScoreP(1)
            .TName = 1
        ElseIf ScoreP(2) > ScoreP(1) Then
            .TScore = ScoreP(2)
            .TName = 2
        End If
        If .TScore > LoadHighScore Then LoadHighScore = .TScore
    End With

SetTextColor HdcViewBuf, vbBlue
SetTextAlign HdcViewBuf, TA_CENTER Or TA_TOP Or TA_NOUPDATECP
Call TextOut(HdcViewBuf, Map.HeadMapFile.WidthTotal \ 2 + LR, 5, "High Score", 10)
Call TextOut(HdcViewBuf, Map.HeadMapFile.WidthTotal \ 2 + LR, 20, Format(LoadHighScore, "0000000000"), 10)

If (Not IsLoadP(1)) And (Not IsLoadP(2)) Then
    '自从此处开始，应用了很多对象属性以及vb中的方法，使速度减慢许多
    '但因为不是主要运行模块，没有进行优化
    If CurPauseFps < 100 Then
            CurPauseFps = CurPauseFps + 1
    Else
            IsPaused = True
            If Not IsShowScore Then
                    Call ShowWindow(HwndShowScore, SW_NORMAL)
            
                    Open App.Path & "\ListPro\ListScore.ini" For Input As #1
                        N = 1
                        Do While Not EOF(1)
                            Line Input #1, ScoreStr(N)
                            N = N + 1
                        Loop
                    Close #1
                    
                    For N = 1 To 17
                            SLen = 21
                            For M = 1 To Len(ScoreStr(N))
                                If Asc(Mid(ScoreStr(N), M, 1)) < 0 Then SLen = SLen - 1
                                If SLen = 0 Then Exit For
                            Next M
                        If MScoreStr.TScore > Val(Mid(ScoreStr(N), SLen, 10)) Then
                            For M = 17 To N + 1 Step -1
                                ScoreStr(M) = ScoreStr(M - 1)
                            Next M
                            SLen = 20
                            For M = 1 To Len(PlayName(MScoreStr.TName))
                                If Asc(Mid(PlayName(MScoreStr.TName), M, 1)) < 0 Then SLen = SLen - 1
                                If SLen = 0 Then Exit For
                            Next M
                            ScoreStr(N) = PlayName(MScoreStr.TName) & Space(SLen - Len(PlayName(MScoreStr.TName))) & Format(MScoreStr.TScore, "0000000000") & Space(2) & Date & " " & Time & Space(20 - SLen)
                            Exit For
                        End If
                    Next N
                    Open App.Path & "\ListPro\ListScore.ini" For Output As #1
                        For N = 1 To 17
                            Print #1, ScoreStr(N)
                        Next N
                    Close #1
                    'FrmMain.TimerMain.Enabled = True
                    MainTime = 0
            End If
            If IsShowScore Then
                    Call ShowScore
                    DrawScore HdcShowScore, ScoreStr, 10, 50, 17, &HFF00FF
                    MainTime = MainTime + 1
                    If MainTime = 200 Then IsPlaying = False: MainTime = 999: FrmMain.TimerMain.Enabled = True
                    
            End If
            IsShowScore = True
    End If
Else
    If IsShowScore Then
        CurPauseFps = 0
        IsPaused = False
        Call ShowWindow(HwndShowScore, SW_HIDE)
    '    Call FrmMain.Form_KeyUp(vbKeyF4, 0)
        IsShowScore = False
    End If
End If
If IsLoadP(1) Then
    ShowLife HdcViewBuf, MaxLeft + LR + 20, 460, 2, 3, PlayPla(1).CurLife + 1, &HFF, &HFF0000
    ShowHoldFire HdcViewBuf, MaxLeft + LR + 50, 468, 3, HoldFps(1)
    ShowBomb HdcViewBuf, MaxLeft + LR + 48, 445, PlayPla(1).CurBombNum
End If
If IsLoadP(2) Then
    ShowLife HdcViewBuf, MaxRight + LR - 80, 460, 2, 3, PlayPla(2).CurLife + 1, &HFF, &HFF0000
    ShowHoldFire HdcViewBuf, MaxRight + LR - 50, 468, 3, HoldFps(2)
    ShowBomb HdcViewBuf, MaxRight + LR - 52, 445, PlayPla(2).CurBombNum
End If
Call ShowTotalAndMap(HdcViewBuf, MidX + LR, 460)
End Sub

Public Sub DrawCurContinue(ByVal WhP As Byte, ByVal Sxx As Integer)
Dim CurCon As Byte
Dim Dx As Integer
Dim CN As Integer
    CurCon = IIf((CurContinueP(WhP) >= 6), 6, CurContinueP(WhP))    '最多显示6个
    For CN = 0 To CurCon - 2
        Call StretchBlt(HdcViewBuf, Sxx + LR + CN * 14, 30, 13, 13, PlayPla(WhP).HdcBack, 0, 0, LoadPla(WhP).Width, LoadPla(WhP).Height, vbSrcCopy) ' &HCC0020) '
    Next CN
End Sub
Public Sub ShowScore()
    'If SS <> 0 Then Exit Sub
    'Dim Al As AlphaFlag, Bl As Long
    'With Al
    '    .CC = 128
    'End With
    'RtlMoveMemory Bl, Al, 4
    'FrmMain.PicShowScore.Cls
    'Call AlphaBlend(FrmMain.PicShowScore.hdc, 0, 0, 300, 400, HdcViewBuf, LR + FrmMain.PicShowScore.Left - (FrmMain.ScaleWidth - Map.HeadMapFile.WidthTotal) \ 2, FrmMain.PicShowScore.Top, 300, 400, Bl)
    Call BitBlt(HdcShowScoreBuf, 0, 0, 300, 400, HdcViewBuf, LR + FrmMain.PicShowScore.Left - (FrmMain.ScaleWidth - Map.HeadMapFile.WidthTotal) \ 2, FrmMain.PicShowScore.Top, vbSrcCopy)
    'SavePicture FrmMain.PicShowScoreBuf.Image, "c:\windows\desktop\1.bmp"
    'Stop
    'Call BitBlt(HdcShowScore, 0, 0, 300, 400, HdcShowScoreBuf, 0, 0, vbSrcCopy)
    Call FoxBrightness(HdcShowScore, FrmMain.PicShowScore.Image.Handle, HdcShowScoreBuf, FrmMain.PicShowScoreBuf.Image.Handle, 70) ', 0, &H1)
    'FrmMain.PicShowScore.Refresh
End Sub


Public Sub DrawPixel()
Dim DP As Byte
    For DP = 1 To MaxPixel
        With BacPixel(DP)
            If .X > 0 Then
                .Y = .Y + .Speed
                If .Y > 484 Then .X = 0
            End If
            
            SetPixelV HdcViewBuf, .X, .Y, &HFFFFFF
            SetPixelV HdcViewBuf, .X, .Y - 1, &HCCCCCC
            SetPixelV HdcViewBuf, .X, .Y - 2, &H888888
            SetPixelV HdcViewBuf, .X, .Y - 3, &H666666
            SetPixelV HdcViewBuf, .X, .Y - 4, &H444444
        End With