graphicsengine.bas

超级C&C有没有搞错,VB还能编出这种即时策略游戏来!没错,这就是我们的超级C&C!虽然游戏经常无故退出,但是原码仍有很多可圈可点的地方.祝你早日编出中国的超级RA,超级KKND,超级星际,超级家园

        End If
    End If
Next I2
If NextToRender > 0 Then
  For I = NextToRender To 1 Step -1
    With Objects(EntitiesToRender(I))
      If ObjModels(.ModelIndex).Abilities(ABILITY_HASSHADOW) = True Then
        If .Position.Z > GroundBlocks(.MapPosition.X, .MapPosition.Y).Height Then
          Call PutGraphicOntoBattleView(RenderX(EntitiesToRender(I)), ProjectYToView(Objects(EntitiesToRender(I)).Position.Y) - (GroundBlocks(.MapPosition.X, .MapPosition.Y).Height / 3), ObjModels(.ModelIndex).Attributes(ATTRIBUTE_SHADOWPIC), 0, ObjModels(.ModelIndex).Attributes(ATTRIBUTE_TOPSPRITEPOSITIONX), ObjModels(.ModelIndex).Attributes(ATTRIBUTE_TOPSPRITEPOSITIONY))
        End If
      End If
      Call PutGraphicOntoBattleView(RenderX(EntitiesToRender(I)), RenderY(EntitiesToRender(I)), SpriteStuff.Sprites(.Sprite.SpriteNumber).SpriteGroups(.Sprite.SpriteGroupNumber).Frames(.Sprite.SpriteFrameNumber).PicNum, .DisplayDirection, ObjModels(.ModelIndex).Attributes(ATTRIBUTE_SPRITEPOSITIONX), ObjModels(.ModelIndex).Attributes(ATTRIBUTE_SPRITEPOSITIONY))
      If ObjModels(.ModelIndex).Abilities(ABILITY_BODYISBISECTED) = True Then
        Call PutGraphicOntoBattleView(RenderX(EntitiesToRender(I)), RenderY(EntitiesToRender(I)), SpriteStuff.Sprites(.TopSprite.SpriteNumber).SpriteGroups(.TopSprite.SpriteGroupNumber).Frames(.TopSprite.SpriteFrameNumber).PicNum, .TopDisplayDirection, ObjModels(.ModelIndex).Attributes(ATTRIBUTE_TOPSPRITEPOSITIONX), ObjModels(.ModelIndex).Attributes(ATTRIBUTE_TOPSPRITEPOSITIONY))
      End If
    End With
  Next I
End If
End Sub

Sub RenderAnimations()
'Animations!
For I = 1 To VisualEffects.AnimsActive
  With Animations(I)
    If .Active = True Then
      RenderX = ProjectXToView(.Position.X)
      RenderY = ProjectYToView(.Position.Y)
      If Clip(RenderX, RenderY) = False Then
        PicNum = SpriteStuff.Sprites(.SpriteNum).SpriteGroups(1).Frames(.CurrentFrame).PicNum
        Call PutGraphicOntoBattleView(RenderX, RenderY, PicNum, .CurrentFrame, Pics(PicNum).HalfWidth, Pics(PicNum).HalfHeight)
      End If
    End If
  End With
Next I
End Sub
Sub RenderSparks()
For I = 1 To SparksActive
  With Sparks(I)
    If .Active = True Then
      RenderX = ProjectXToView(.Position.X)
      RenderY = ProjectYToView(.Position.Y) - (.Position.Z / 2)
      If Clip(RenderX, RenderY) = False Then
        HealthVal = .Health + 50
        If HealthVal > 255 Then HealthVal = 255
        ColVal = GetRGBVal(HealthVal, .Pallete)
        a = SetPixelV(lhdc, RenderX, RenderY, ColVal)
      End If
    End If
  End With
Next I
End Sub
Public Sub RenderSparkles()
For I = 1 To SparklesActive
  With Sparkles(I)
    If .Active = True Then
      For I2 = 1 To 3
        RenderX = ProjectXToView(.Position.X) + ((2 * Rnd) - 1)
        RenderY = (ProjectYToView(.Position.Y) - (.Position.Z / 2)) + ((2 * Rnd) - 1)
        If Clip(RenderX, RenderY) = False Then
          ColVal = GetRGBVal(.Health, .Pallete)
          a = SetPixelV(lhdc, RenderX, RenderY, ColVal)
        End If
      Next I2
    End If
  End With
Next I
End Sub
Sub DisplayMessageWindow()
Dim temprect As RECT
temprect.Top = 0
temprect.Left = 0
temprect.bottom = Pics(InGameConstants(InGameConstant_PICINDEX_MessageWindowPic)).Height
temprect.Right = Pics(InGameConstants(InGameConstant_PICINDEX_MessageWindowPic)).Width
ddsBack.BltFast ResolutionMidX - Pics(InGameConstants(InGameConstant_PICINDEX_MessageWindowPic)).HalfWidth, ResolutionMidY - Pics(InGameConstants(InGameConstant_PICINDEX_MessageWindowPic)).HalfHeight, GraphicSurfaces(Pics(InGameConstants(InGameConstant_PICINDEX_MessageWindowPic)).GraphicsLib), temprect, 0
PlaceX = ResolutionMidX - (((Len(MessageWindow.Caption) + 1) * FONT_SPACINGX) / 2)
PlaceY = (ResolutionMidY - Pics(InGameConstants(InGameConstant_PICINDEX_MessageWindowPic)).HalfHeight)
Call DisplayText(MessageWindow.Caption, PlaceX, PlaceY + 13, 0)

LineSize = 26
EndPoint = LineSize
If EndPoint > Len(MessageWindow.Text) Then EndPoint = Len(MessageWindow.Text)
StartPoint = 1
Do
  Call DisplayText(Mid$(MessageWindow.Text, StartPoint, (EndPoint - StartPoint) + 1), (ResolutionMidX - Pics(InGameConstants(InGameConstant_PICINDEX_MessageWindowPic)).HalfWidth) + 15, PlaceY + 38 + (LineCount * FONT_SPACINGY), 0)
  If EndPoint = Len(MessageWindow.Text) Then Exit Do
  StartPoint = StartPoint + LineSize
  If StartPoint > Len(MessageWindow.Text) Then Exit Do
  EndPoint = EndPoint + LineSize
  If EndPoint > Len(MessageWindow.Text) Then EndPoint = Len(MessageWindow.Text)
  LineCount = LineCount + 1
Loop
End Sub
Sub OpenGraphicsDevice()
' Set some constant values (from WIN32API.TXT).
Const conHwndTopmost = -1
Const conHwndNoTopmost = -2
Const conSwpNoActivate = &H10
Const conSwpShowWindow = &H40

Call ViewForm.OpenGameView
' Turn on the TopMost attribute.
SetWindowPos ViewForm.hwnd, conHwndTopmost, 0, 0, 0, 0, conSwpNoActivate Or conSwpShowWindow

DirectDrawCreate ByVal 0&, dd, Nothing
' This app is full screen and will change the display mode
dd.SetCooperativeLevel ViewForm.hwnd, DDSCL_EXCLUSIVE Or DDSCL_FULLSCREEN
' Set the display mode
dd.SetDisplayMode ResolutionX, ResolutionY, ColorDepth, 0, 0
With ddsdFront
  ' Structure size
  .dwSize = Len(ddsdFront)
  ' Use DDSD_CAPS and BackBufferCount
  .dwFlags = DDSD_CAPS Or DDSD_BACKBUFFERCOUNT
  ' Primary, flipable surface
  
  If Program.ProgramData.UsesSystemMemoryForBackbuffer = True Then
    .DDSCAPS.dwCaps = DDSCAPS_PRIMARYSURFACE Or DDSCAPS_FLIP Or DDSCAPS_COMPLEX Or DDSCAPS_SYSTEMMEMORY
  Else
    .DDSCAPS.dwCaps = DDSCAPS_PRIMARYSURFACE Or DDSCAPS_FLIP Or DDSCAPS_COMPLEX
  End If
  ' One back buffer (you can try 2)
  .dwBackBufferCount = 1
End With
WindowRect.Top = 0
WindowRect.Left = 0
WindowRect.Right = ResolutionX
WindowRect.bottom = ResolutionY
BattleSurfaceRect.Top = 0
BattleSurfaceRect.Left = 0
BattleSurfaceRect.Right = BattleViewPort.Width
BattleSurfaceRect.bottom = BattleViewPort.Height

dd.CreateSurface ddsdFront, ddsFront, Nothing
ddCaps.dwCaps = DDSCAPS_BACKBUFFER
ddsFront.GetAttachedSurface ddCaps, ddsBack
fx.ddckSrcColorkey.dwColorSpaceHighValue = RGB(0, 0, 0)
fx.ddckSrcColorkey.dwColorSpaceLowValue = RGB(0, 0, 0)
fx.dwSize = Len(fx)
FxClear.dwSize = Len(fx)
FxClear.dwFillColor = RGB(0, 0, 0)
GraphicsEngineData.DeviceOpen = True
Set TerrainSurface = CreateSurface(BattleViewPort.Width, BattleViewPort.Height)
Set BattleSurface = CreateSurface(BattleViewPort.Width, BattleViewPort.Height)
Set ControlPanelSurface = CreateSurface(GameControlPanel.Width, GameControlPanel.Height)
'ShowCursor 0
End Sub
Public Sub ChangeGraphicsMode(ResX, ResY, BitDepth)
ResolutionX = ResX
ResolutionY = ResY
ResolutionMidX = ResX / 2
ResolutionMidY = ResY / 2
FONT_LastCharacter = ResolutionX / FONT_SPACINGX
FONT_LastLine = ResolutionY / FONT_SPACINGY
ColorDepth = BitDepth
End Sub
Sub ClearBackBuffer()
Call GraphicsEngine.TilePic(InGameConstants(InGameConstant_PICINDEX_ClearBackground))
End Sub
Sub TempOpenGraphicsDevice()
Call ViewForm.OpenGameView
DirectDrawCreate ByVal 0&, dd, Nothing
' This app is full screen and will change the display mode
dd.SetCooperativeLevel ViewForm.hwnd, DDSCL_EXCLUSIVE Or DDSCL_FULLSCREEN
' Set the display mode
dd.SetDisplayMode ResolutionX, ResolutionY, ColorDepth, 0, 0
With ddsdFront
  ' Structure size
  .dwSize = Len(ddsdFront)
  ' Use DDSD_CAPS and BackBufferCount
  .dwFlags = DDSD_CAPS Or DDSD_BACKBUFFERCOUNT
  ' Primary, flipable surface
  
  If Program.ProgramData.UsesSystemMemoryForBackbuffer = True Then
    .DDSCAPS.dwCaps = DDSCAPS_PRIMARYSURFACE Or DDSCAPS_FLIP Or DDSCAPS_COMPLEX Or DDSCAPS_SYSTEMMEMORY
  Else
    .DDSCAPS.dwCaps = DDSCAPS_PRIMARYSURFACE Or DDSCAPS_FLIP Or DDSCAPS_COMPLEX
  End If
  ' One back buffer (you can try 2)
  .dwBackBufferCount = 1
End With
dd.CreateSurface ddsdFront, ddsFront, Nothing
ddCaps.dwCaps = DDSCAPS_BACKBUFFER
ddsFront.GetAttachedSurface ddCaps, ddsBack
fx.ddckSrcColorkey.dwColorSpaceHighValue = 0
fx.ddckSrcColorkey.dwColorSpaceLowValue = 0
fx.dwSize = Len(fx)
FxClear.dwSize = Len(fx)
FxClear.dwFillColor = RGB(0, 0, 0)
GraphicsEngineData.DeviceOpen = True
TerrainSurface.Restore
BattleSurface.Restore
ControlPanelSurface.Restore
'ShowCursor 0
End Sub
Sub TempCloseGraphicsDevice()
DoEvents
dd.FlipToGDISurface
dd.RestoreDisplayMode
dd.SetCooperativeLevel 0, DDSCL_NORMAL
GraphicsEngineData.DeviceOpen = False
End Sub
Sub CloseGraphicsDevice()
'ShowCursor 1
Call SpriteStuff.UnloadGraphicLibraries
Set TerrainSurface = Nothing
Set ControlPanelSurface = Nothing
Set BattleSurface = Nothing
DoEvents
dd.FlipToGDISurface
dd.RestoreDisplayMode
dd.SetCooperativeLevel 0, DDSCL_NORMAL
Set ddsBack = Nothing
Set ddsFront = Nothing
Set dd = Nothing
Call ViewForm.DestroyGameView
GraphicsEngineData.DeviceOpen = False
End Sub
Sub DrawBox(X1, Y1, X2, Y2, R1, G1, B1, R2, G2, B2, Mode)
If Mode = LINEMODE_NORMAL Then
  If X2 < X1 Then
    X3 = X1
    X1 = X2
    X2 = X1
  End If
  If Y2 < Y1 Then
    Y3 = Y1
    Y1 = Y2
    Y2 = Y1
  End If
  Color1 = RGB(R1, G1, B1)
  Y = Y1
  For X = X1 To X2
    SetPixelV lhdc, X, Y, Color1
  Next X
  Y = Y2
  For X = X1 To X2
    SetPixelV lhdc, X, Y, Color1
  Next X
  X = X1
  For Y = Y1 To Y2
    SetPixelV lhdc, X, Y, Color1
  Next Y
  X = X2
  For Y = Y1 To Y2
    SetPixelV lhdc, X, Y, Color1
  Next Y
Else
  Call DrawLine(X1, Y1, X2, Y1, R1, G1, B1, R2, G2, B2, Mode)
  Call DrawLine(X1, Y1, X1, Y2, R1, G1, B1, R2, G2, B2, Mode)
  Call DrawLine(X2, Y2, X2, Y1, R1, G1, B1, R2, G2, B2, Mode)
  Call DrawLine(X2, Y2, X1, Y2, R1, G1, B1, R2, G2, B2, Mode)
End If
End Sub
Sub DrawLine(X1, Y1, X2, Y2, R1, G1, B1, R2, G2, B2, Mode)
On Error Resume Next
XDiff = X1 - X2
YDiff = Y1 - Y2
If YDiff < 0 Then ChangeY = True: YDiff = -YDiff
If XDiff < 0 Then ChangeX = True: XDiff = -XDiff
If YDiff > XDiff Then
  LengthOfLine = YDiff
  XInc = XDiff / YDiff
  YInc = 1
Else
  LengthOfLine = XDiff
  YInc = YDiff / XDiff
  XInc = 1
End If
If ChangeY = True Then YInc = -YInc
If ChangeX = True Then XInc = -XInc
CurrX = X1
CurrY = Y1
Select Case Mode
Case LINEMODE_SHADE
  RDiff = R2 - R1
  RI = (RDiff / LengthOfLine)
  GDiff = G2 - G1
  GI = (GDiff / LengthOfLine)
  BDiff = B2 - B1
  BI = (BDiff / LengthOfLine)
End Select
SetPixelV lhdc, X1, Y1, RGB(R1, G1, B1)
For I = 1 To LengthOfLine
  CurrX = CurrX - XInc
  CurrY = CurrY - YInc
  Select Case Mode
  Case LINEMODE_NORMAL
    Color1 = RGB(R1, G1, B1)
  Case LINEMODE_SHADE
    Color1 = RGB(R1 + (RI * I), G1 + (GI * I), B1 + (BI * I))
  End Select
  SetPixelV lhdc, CurrX, CurrY, Color1
Next I
End Sub
Private Function CreateSurface(Width, Height) As DirectDrawSurface2
Dim ddsd As DDSURFACEDESC       ' Surface description
Dim dds As DirectDrawSurface2   ' Created surface
With ddsd
    .dwSize = Len(ddsd)
    .dwFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH
    .DDSCAPS.dwCaps = DDSCAPS_OFFSCREENPLAIN
    .dwWidth = Width
    .dwHeight = Height
End With
dd.CreateSurface ddsd, dds, Nothing

' Restore the surface
dds.Restore
' Returns the new surface
Set CreateSurface = dds
End Function
Private Sub LoadGraphicOntoGraphicLib(Index, dd As DirectDraw2, ByVal strFile As String)
Dim hbm As Long                 ' Handle on bitmap
Dim bm As BITMAP                ' Bitmap header
Dim ddsd As DDSURFACEDESC       ' Surface description
Dim dds As DirectDrawSurface2   ' Created surface
Dim hdcImage As Long            ' Handle on image