graphicsengine.bas

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

Attribute VB_Name = "GraphicsEngine"
Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Global ResolutionX As Integer
Global ResolutionY As Integer
Global ResolutionMidX As Integer
Global ResolutionMidY As Integer
Global ColorDepth As Integer

' Transparent Blit
Option Compare Text

Global WindowRect As RECT
' Win32
Const IMAGE_BITMAP = 0
Const LR_LOADFROMFILE = &H10
Const LR_CREATEDIBSECTION = &H2000
Const SRCCOPY = &HCC0020

Global BattleSurfaceRect As RECT

Global Const FONT_SPACINGX = 8
Global Const FONT_SPACINGY = 12
Global Const FONT_SIZE = 12
Global FONT_LastCharacter As Integer
Global FONT_LastLine As Integer
Private FxClear As DDBLTFX
Private Type GfxEng
  TotalRefresh As Boolean
  DeviceOpen As Boolean
  TerrainRefreshSize As Integer
End Type
Public GraphicsEngineData As GfxEng
Private Type BITMAP
  bmType  As Long
  bmWidth  As Long
  bmHeight  As Long
  bmWidthBytes  As Long
  bmPlanes  As Integer
  bmBitsPixel  As Integer
  bmBits  As Long
End Type
' GDI32

Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
' USER32
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function LoadImage Lib "user32" Alias "LoadImageA" (ByVal hInst As Long, ByVal lpsz As String, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 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 SetPixelV Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Private Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long
'&HCC0020 is the dwRop (raster operation) thingy for using stretchblt to copy a pic
Dim dd As DirectDraw2
'Terrain
Private TerrainSurface As DirectDrawSurface3
'Battleview
Private BattleSurface As DirectDrawSurface3
'Control panel
Private ControlPanelSurface As DirectDrawSurface3

Private ddsdFront As DDSURFACEDESC      ' Front surface description
Private ddsFront As DirectDrawSurface3  ' Front buffer
Private ddsBack As DirectDrawSurface3
Private fx As DDBLTFX

Private ddCaps As DDSCAPS               ' Capabilities for search
Private lhdc As Long                    ' hDC for back buffer
Private PFormat1 As DDPIXELFORMAT
Global Const LINEMODE_NORMAL = 1
Global Const LINEMODE_SHADE = 2
Global Const BltType_Mask = 1
Global Const BltType_Fast = 2
Global GraphicSurfaces(100) As DirectDrawSurface3
Sub prepSrcColorKey(srf As DirectDrawSurface3)
Dim aColorkey As DDCOLORKEY
aColorkey.dwColorSpaceHighValue = 0
aColorkey.dwColorSpaceLowValue = 0
srf.SetColorKey DDCKEY_SRCBLT, aColorkey
End Sub
Public Sub SplashGraphic(PicIndex)
Dim SrcBox As RECT
SrcBox.Left = Pics(PicIndex).SourceRect.Left
SrcBox.Top = Pics(PicIndex).SourceRect.Top
SrcBox.bottom = Pics(PicIndex).Height + Pics(PicIndex).SourceRect.Top
SrcBox.Right = Pics(PicIndex).Width + Pics(PicIndex).SourceRect.Left
ddsBack.BltFast ResolutionMidX - Pics(PicIndex).HalfWidth, ResolutionMidY - Pics(PicIndex).HalfHeight, GraphicSurfaces(Pics(PicIndex).GraphicsLib), SrcBox, 0

End Sub
Public Sub RefreshRender()
TerrainSurface.Restore
Call ControlPanelSurface.Restore
Call RedrawControlPanel
Call RenderTerrain
End Sub
Public Sub GethDC()
ddsBack.GetDC lhdc
End Sub
Public Sub ReleasehDC()
ddsBack.ReleaseDC lhdc

End Sub
Public Sub DrawCursor()
'Cursor
'Call GraphicsEngine.PutGraphicOntoBackBuffer(Mouse.Position.X, Mouse.Position.Y, GameInterface.Mouse.CursorPic, BltType_Mask)
End Sub
Public Sub PutGraphicOntoBackBuffer(X, Y, PicIndex, BltType)
Dim DestBox As RECT, SrcBox As RECT
DestBox.Top = Y - Pics(PicIndex).HalfHeight
DestBox.Left = X - Pics(PicIndex).HalfWidth
DestBox.bottom = Y + Pics(PicIndex).HalfHeight
DestBox.Right = X + Pics(PicIndex).HalfWidth
SrcBox.Top = Pics(PicIndex).SourceRect.Top
SrcBox.Left = Pics(PicIndex).SourceRect.Left
SrcBox.bottom = Pics(PicIndex).SourceRect.Top + Pics(PicIndex).Height
SrcBox.Right = Pics(PicIndex).SourceRect.Left + Pics(PicIndex).Width
If DestBox.bottom > 0 Then
  If DestBox.Top < ResolutionY Then
    If DestBox.Right > 0 Then
      If DestBox.Left < ResolutionX Then
        If DestBox.Top < 0 Then
          SrcBox.Top = SrcBox.Top - DestBox.Top
          DestBox.Top = 0
        End If
        If DestBox.bottom > ResolutionY Then
          SrcBox.bottom = SrcBox.bottom - (DestBox.bottom - ResolutionY)
          DestBox.bottom = ResolutionY
        End If
        If DestBox.Left < 0 Then
          SrcBox.Left = SrcBox.Left - DestBox.Left
          DestBox.Left = 0
        End If
        If DestBox.Right > ResolutionX Then
          SrcBox.Right = SrcBox.Right - (DestBox.Right - ResolutionX)
          DestBox.Right = ResolutionX
        End If
        ' Set the transparent color
        GraphicSurfaces(Pics(PicIndex).GraphicsLib).Restore
        ' Blit the image to the back buffer
        Select Case BltType
        Case BltType_Mask
          ddsBack.BltFast DestBox.Left, DestBox.Top, GraphicSurfaces(Pics(PicIndex).GraphicsLib), SrcBox, DDBLTFAST_WAIT Or DDBLTFAST_SRCCOLORKEY
        Case BltType_Fast
          ddsBack.BltFast DestBox.Left, DestBox.Top, GraphicSurfaces(Pics(PicIndex).GraphicsLib), SrcBox, 0
        End Select
      End If
    End If
  End If
End If

End Sub
Public Sub SwapScreen()
ddsFront.Flip Nothing, 0
End Sub
Public Sub PutGraphicOntoTerrain(X, Y, PicIndex, Direction, BltType As Integer)
Dim DestBox As RECT, SrcBox As RECT
With Pics(PicIndex)
    DestBox.Top = Y - .HalfHeight
    DestBox.Left = X - .HalfWidth
    DestBox.bottom = Y + .HalfHeight
    DestBox.Right = X + .HalfWidth
    SrcBox.Top = .SourceRect.Top
    SrcBox.Left = .SourceRect.Left + (.Width * Direction)
    SrcBox.bottom = .SourceRect.Top + .Height
    SrcBox.Right = .SourceRect.Left + .Width + (.Width * Direction)
    If DestBox.bottom > 0 Then
      If DestBox.Top < BattleViewPort.Height Then
        If DestBox.Right > 0 Then
          If DestBox.Left < BattleViewPort.Width Then
            If DestBox.Top < 0 Then
              SrcBox.Top = SrcBox.Top - DestBox.Top
              DestBox.Top = 0
            End If
            If DestBox.bottom > BattleViewPort.Height Then
              SrcBox.bottom = SrcBox.bottom - (DestBox.bottom - BattleViewPort.Height)
              DestBox.bottom = BattleViewPort.Height
            End If
            If DestBox.Left < 0 Then
              SrcBox.Left = SrcBox.Left - DestBox.Left
              DestBox.Left = 0
            End If
            If DestBox.Right > BattleViewPort.Width Then
              SrcBox.Right = SrcBox.Right - (DestBox.Right - BattleViewPort.Width)
              DestBox.Right = BattleViewPort.Width
            End If
            ' Set the transparent color
            
            
            GraphicSurfaces(.GraphicsLib).Restore
            ' Blit the image to the back buffer
            Select Case BltType
            Case BltType_Mask
              TerrainSurface.BltFast DestBox.Left, DestBox.Top, GraphicSurfaces(.GraphicsLib), SrcBox, DDBLTFAST_WAIT Or DDBLTFAST_SRCCOLORKEY
            Case BltType_Fast
              TerrainSurface.BltFast DestBox.Left, DestBox.Top, GraphicSurfaces(.GraphicsLib), SrcBox, 0
            End Select
          End If
        End If
      End If
    End If
End With
End Sub
Public Sub PutGraphicOntoBattleView(X, Y, PicIndex, Direction, SpriteXOffset, SpriteYOffset)
Dim DestBox As RECT, SrcBox As RECT
On Error Resume Next
With Pics(PicIndex)
    DestBox.Top = Y - SpriteYOffset
    DestBox.Left = X - SpriteXOffset
    DestBox.bottom = (Y - SpriteYOffset) + .Height
    DestBox.Right = (X - SpriteXOffset) + .Width
    SrcBox.Top = .SourceRect.Top
    SrcBox.Left = .SourceRect.Left + (.Width * Direction)
    SrcBox.bottom = .SourceRect.Top + .Height
    SrcBox.Right = .SourceRect.Left + (.Width * (Direction + 1))
End With
With DestBox
  If .bottom > 0 Then
    If .Top < BattleSurfaceRect.bottom Then
      If .Right > 0 Then
        If .Left < BattleSurfaceRect.Right Then
          If .Top < 0 Then
            SrcBox.Top = SrcBox.Top - .Top
            .Top = 0
          End If
          If .bottom > BattleSurfaceRect.bottom Then
            SrcBox.bottom = SrcBox.bottom - (.bottom - BattleSurfaceRect.bottom)
          End If
          If .Left < 0 Then
            SrcBox.Left = SrcBox.Left - .Left
            .Left = 0
          End If
          If .Right > BattleSurfaceRect.Right Then
            SrcBox.Right = SrcBox.Right - (.Right - BattleSurfaceRect.Right)
          End If
          GraphicSurfaces(Pics(PicIndex).GraphicsLib).Restore
          BattleSurface.BltFast .Left, .Top, GraphicSurfaces(Pics(PicIndex).GraphicsLib), SrcBox, DDBLTFAST_WAIT Or DDBLTFAST_SRCCOLORKEY
        End If
      End If
    End If
  End If
End With
End Sub
Public Function ClipPic(X, Y, PicIndex, OffsetX, OffsetY) As Boolean
ClipPic = False
If X - OffsetX > BattleViewPort.Width Then
  ClipPic = True
End If
If Y - OffsetY > BattleViewPort.Height Then
  ClipPic = True
End If
If (X + Pics(PicIndex).Width) - OffsetX < 0 Then
  ClipPic = True
End If
If (Y + Pics(PicIndex).Height) - OffsetY < 0 Then
  ClipPic = True
End If
End Function
Public Function Clip(X, Y) As Boolean
If X < 0 Then
  Clip = True
End If
If Y < 0 Then
  Clip = True
End If
If X > BattleViewPort.Width Then
  Clip = True
End If
If Y > BattleViewPort.Height Then
  Clip = True
End If
End Function
Public Function GetRGBVal(ColorValue, Pallete)
Select Case Pallete
Case PALLETE_RED
  GetRGBVal = RGB(ColorValue, 0, 0)
Case PALLETE_GREEN
  GetRGBVal = RGB(0, ColorValue, 0)
Case PALLETE_BLUE
  GetRGBVal = RGB(0, 0, ColorValue)
Case PALLETE_WHITE
  GetRGBVal = RGB(ColorValue, ColorValue, ColorValue)
Case PALLETE_YELLOW
  GetRGBVal = RGB(ColorValue, ColorValue, 0)
Case PALLETE_SKYBLUE
  GetRGBVal = RGB(0, ColorValue / 2, ColorValue)
End Select
End Function
Sub RenderTerrain()
For X = Map.ProjectToMapX(View.Left) To Map.ProjectToMapX(View.Left + View.Width)
  For Y = Map.ProjectToMapY(View.Top) To Map.ProjectToMapY(View.Top + View.Height)
    Call RenderTerrainBlock(X, Y)
  Next Y
Next X
End Sub
Sub UpdateScenery()
Static Count
Count = Count + 1
If Count = 6 Then
  Count = 0
  For X = Map.ProjectToMapX(View.Left) To Map.ProjectToMapX(View.Left + View.Width)
    For Y = Map.ProjectToMapY(View.Top) To Map.ProjectToMapY(View.Top + View.Height)
      If GroundBlocks(X, Y).TerrainType = TERRAINTYPE_WATER Then
        Call RenderTerrainBlock(X, Y)
        For I = 1 To GroundBlocks(X, Y).TerrainOverlayAmount
          GroundBlocks(X, Y).AnimFrames(I) = GroundBlocks(X, Y).AnimFrames(I) + 1
          If GroundBlocks(X, Y).AnimFrames(I) > Sprites(GroundBlocks(X, Y).SpriteNumbers(I)).SpriteGroups(GroundBlocks(X, Y).DamageAmount + 1).FrameMax Then
            GroundBlocks(X, Y).AnimFrames(I) = 1
          End If
        Next I
      End If
    Next Y
  Next X
End If
End Sub
Sub MoveTerrain(Direction, Distance)