editor.frm

VB6+DX7开发即时战略游戏(游戏代码+编辑器)

VERSION 5.00
Begin VB.Form Editor 
   Caption         =   "地图编辑器"
   ClientHeight    =   3195
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4680
   LinkTopic       =   "Form1"
   ScaleHeight     =   213
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   312
   StartUpPosition =   3  'Windows Default
   WindowState     =   2  'Maximized
   Begin VB.CommandButton Command4 
      Caption         =   "map mode"
      Height          =   615
      Left            =   10200
      TabIndex        =   8
      Top             =   2640
      Width           =   1215
   End
   Begin VB.CommandButton Command3 
      Caption         =   "enemy1 mode"
      Height          =   615
      Left            =   10200
      TabIndex        =   7
      Top             =   1920
      Width           =   1215
   End
   Begin VB.CommandButton Command1 
      Caption         =   "ma mode"
      Height          =   615
      Left            =   10200
      TabIndex        =   6
      Top             =   1200
      Width           =   1215
   End
   Begin VB.CommandButton open 
      Caption         =   "open and show"
      Height          =   615
      Left            =   8400
      TabIndex        =   5
      Top             =   3600
      Width           =   1215
   End
   Begin VB.CommandButton save 
      Caption         =   "save"
      Height          =   615
      Left            =   8400
      TabIndex        =   4
      Top             =   2760
      Width           =   1215
   End
   Begin VB.CommandButton Command2 
      Caption         =   "Tile"
      Height          =   615
      Left            =   8400
      TabIndex        =   2
      Top             =   2040
      Width           =   1215
   End
   Begin VB.CommandButton refresh 
      Caption         =   "刷新"
      Height          =   615
      Left            =   8400
      TabIndex        =   1
      Top             =   1200
      Width           =   1215
   End
   Begin VB.PictureBox Picture1 
      Appearance      =   0  'Flat
      BackColor       =   &H80000005&
      ForeColor       =   &H80000008&
      Height          =   7485
      Left            =   120
      ScaleHeight     =   497
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   497
      TabIndex        =   0
      Top             =   150
      Width           =   7485
   End
   Begin VB.Label Label1 
      Appearance      =   0  'Flat
      BackColor       =   &H80000005&
      BorderStyle     =   1  'Fixed Single
      ForeColor       =   &H80000008&
      Height          =   615
      Left            =   8400
      TabIndex        =   3
      Top             =   240
      Width           =   1455
   End
End
Attribute VB_Name = "Editor"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Dim D7 As New DirectX7        '定义D7

Dim DDraw As DirectDraw7      '定义DDRAW

Dim PrimarySurface As DirectDrawSurface7    '定义primarysurface
Dim ddsdPrimary As DDSURFACEDESC2

Dim BackbufferSurface As DirectDrawSurface7     '定义backbuffersurface
Dim ddsdBackbufferSurface As DDSURFACEDESC2

Dim Red As DirectDrawSurface7           '定义一些表面
Dim ddsdRed As DDSURFACEDESC2

Dim Green As DirectDrawSurface7
Dim ddsdGreen As DDSURFACEDESC2

Dim Black As DirectDrawSurface7
Dim ddsdBlack As DDSURFACEDESC2

Dim Blue As DirectDrawSurface7
Dim ddsdBlue As DDSURFACEDESC2

Dim Ma As DirectDrawSurface7
Dim ddsdMa As DDSURFACEDESC2

Dim Enemy1 As DirectDrawSurface7
Dim ddsdEnemy1 As DDSURFACEDESC2

Dim Map As DirectDrawSurface7
Dim ddsdMap As DDSURFACEDESC2



Sub InitDDraw()     '初始化directdraw

'Me.Show              '显示主窗体
'ShowCursor False     '隐藏鼠标

Set DDraw = D7.DirectDrawCreate("")    '创建DDRAW

Call DDraw.SetCooperativeLevel(Me.hWnd, DDSCL_NORMAL)
'DDraw.SetDisplayMode 800, 600, 16, 0, DDSDM_STANDARDVGAMODE

'初始化primary 和backbuffersurface
ddsdPrimary.lFlags = DDSD_CAPS
ddsdPrimary.ddsCaps.lCaps = DDSCAPS_PRIMARYSURFACE
Set PrimarySurface = DDraw.CreateSurface(ddsdPrimary)

ddsdBackbufferSurface.lFlags = DDSD_CAPS Or DDSD_WIDTH Or DDSD_HEIGHT
ddsdBackbufferSurface.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN Or DDSCAPS_VIDEOMEMORY     '这个缓冲要做到显存里
ddsdBackbufferSurface.lHeight = DisplayHeight      '这个缓冲区的大小可以根据需要调节
ddsdBackbufferSurface.lWidth = DisplayWidth
Set BackbufferSurface = DDraw.CreateSurface(ddsdBackbufferSurface)


End Sub
Sub InitSurface()         '做各种实际应用的surface
Dim key As DDCOLORKEY     '定义透明色并赋值，以下会多次用到
key.high = 0
key.low = 0

ddsdRed.lFlags = DDSD_CAPS
ddsdRed.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN Or DDSCAPS_VIDEOMEMORY
Set Red = DDraw.CreateSurfaceFromFile("red.bmp", ddsdRed)

ddsdGreen.lFlags = DDSD_CAPS
ddsdGreen.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN Or DDSCAPS_VIDEOMEMORY
Set Green = DDraw.CreateSurfaceFromFile("green.bmp", ddsdGreen)

ddsdBlack.lFlags = DDSD_CAPS
ddsdBlack.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN Or DDSCAPS_VIDEOMEMORY
Set Black = DDraw.CreateSurfaceFromFile("black.bmp", ddsdBlack)

ddsdBlue.lFlags = DDSD_CAPS
ddsdBlue.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN Or DDSCAPS_VIDEOMEMORY
Set Blue = DDraw.CreateSurfaceFromFile("blue.bmp", ddsdBlue)

ddsdMa.lFlags = DDSD_CAPS
ddsdMa.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN Or DDSCAPS_VIDEOMEMORY
Set Ma = DDraw.CreateSurfaceFromFile("ma.bmp", ddsdMa)
Call Ma.SetColorKey(DDCKEY_SRCBLT, key)

ddsdEnemy1.lFlags = DDSD_CAPS
ddsdEnemy1.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN Or DDSCAPS_VIDEOMEMORY
Set Enemy1 = DDraw.CreateSurfaceFromFile("enemy1.bmp", ddsdEnemy1)
Call Enemy1.SetColorKey(DDCKEY_SRCBLT, key)

ddsdMap.lFlags = DDSD_CAPS
ddsdMap.ddsCaps.lCaps = DDSCAPS_OFFSCREENPLAIN Or DDSCAPS_VIDEOMEMORY
Set Map = DDraw.CreateSurfaceFromFile("map.bmp", ddsdMap)
Call Map.SetColorKey(DDCKEY_SRCBLT, key)


End Sub
Sub PaintBackground()
Dim destRect As RECT
Dim srcRect As RECT

srcRect.Right = ddsdBlack.lWidth        'cls以便于观察
srcRect.Bottom = ddsdBlack.lHeight      'cls不是必须的，但加上会有好处
destRect.Right = DisplayWidth - 1
destRect.Bottom = DisplayHeight - 1

Call BackbufferSurface.Blt(destRect, Black, srcRect, DDBLT_WAIT)

Dim i As Integer
Dim j As Integer

For i = 0 To 49
    For j = 0 To 49
        DoEvents
        With srcRect
            .Left = 0
            .Right = TileSize - 1
            .Top = 0
            .Bottom = TileSize - 1
        End With
            
        With destRect
        
            .Left = Tile_Date(i, j).X - TileSize / 2
                
        
            .Right = Tile_Date(i, j).X + TileSize / 2
                
                
            .Top = Tile_Date(i, j).Y - TileSize / 2
                
                
            .Bottom = Tile_Date(i, j).Y + TileSize / 2
                
        
        End With
            
        Select Case Tile_Date(i, j).GraphyIndex
            
            Case Red_Index
                Call BackbufferSurface.Blt(destRect, Red, srcRect, DDBLT_WAIT)
            
            Case Green_Index
                Call BackbufferSurface.Blt(destRect, Green, srcRect, DDBLT_WAIT)
            
            Case Blue_Index
                Call BackbufferSurface.Blt(destRect, Blue, srcRect, DDBLT_WAIT)
            
        End Select
               
    Next j
    
Next i

End Sub
Sub PaintMa()
Dim destRect As RECT
Dim srcRect As RECT

With srcRect
    .Right = TileSize
    .Bottom = TileSize
End With
    
With destRect       '座机总是在屏幕的中央
    .Left = Ma_Date.CurPosX * TileSize
    .Right = Ma_Date.CurPosX * TileSize + TileSize
    .Top = Ma_Date.CurPosY * TileSize
    .Bottom = Ma_Date.CurPosY * TileSize + TileSize
End With
    
    
Call BackbufferSurface.Blt(destRect, Ma, srcRect, DDBLT_WAIT Or DDBLT_KEYSRC)

End Sub
Sub PaintEnemy1()
Dim destRect As RECT
Dim srcRect As RECT
Dim i As Integer

With srcRect
    .Right = TileSize
    .Bottom = TileSize
End With
For i = 0 To 9
    With destRect       '座机总是在屏幕的中央
        .Left = Enemy1_Date(i).CurPosX * TileSize
        .Right = Enemy1_Date(i).CurPosX * TileSize + TileSize
        .Top = Enemy1_Date(i).CurPosY * TileSize
        .Bottom = Enemy1_Date(i).CurPosY * TileSize + TileSize
    End With
    Call BackbufferSurface.Blt(destRect, Enemy1, srcRect, DDBLT_WAIT Or DDBLT_KEYSRC)

Next i

End Sub
Sub PaintMap()
Dim i As Integer
Dim j As Integer
Dim destRect As RECT
Dim srcRect As RECT

For i = 0 To 49
    For j = 0 To 49
        If Tile_Date(i, j).MapIndex <> 0 Then
            DoEvents
            With srcRect
                .Right = TileSize - 1
                .Bottom = TileSize - 1
            End With
            
            With destRect
                .Left = Tile_Date(i, j).X - TileSize / 2
                .Right = Tile_Date(i, j).X + TileSize / 2
                .Top = Tile_Date(i, j).Y - TileSize / 2
                .Bottom = Tile_Date(i, j).Y + TileSize / 2
            End With
            
            Call BackbufferSurface.Blt(destRect, Map, srcRect, DDBLT_WAIT Or DDBLT_KEYSRC)
             
       End If
    Next j
    
Next i

End Sub
Sub InitSystemDate()
GraphyIndex = Red_Index
Pass = True
End Sub
Sub InitNormalDate()
Dim i As Long
Dim j As Long
Randomize

For i = 0 To 49
    For j = 0 To 49
        DoEvents
        Tile_Date(i, j).X = TileSize * i + TileSize / 2
        Tile_Date(i, j).Y = TileSize * j + TileSize / 2
        Tile_Date(i, j).GraphyIndex = Blue_Index
        Tile_Date(i, j).Pass = False
        Tile_Date(i, j).MapIndex = 0
    Next j
Next i

'For i = 0 To 49
    'Tile_Date(0, i).GraphyIndex = Blue_Index
    'Tile_Date(0, i).Pass = False
    
    'Tile_Date(49, i).GraphyIndex = Blue_Index
    'Tile_Date(49, i).Pass = False
    
    'Tile_Date(i, 0).GraphyIndex = Blue_Index
    'Tile_Date(i, 0).Pass = False
    
    'Tile_Date(i, 49).GraphyIndex = Blue_Index
    'Tile_Date(i, 49).Pass = False

'Next i
End Sub
Sub PaintToScreen()     '刷新屏幕
Dim destRect As RECT
Dim srcRect As RECT

Call D7.GetWindowRect(Editor.Picture1.hWnd, destRect)

With srcRect
    .Left = 0
    .Right = DisplayWidth
    .Top = 0
    .Bottom = DisplayHeight
End With

Call PrimarySurface.Blt(destRect, BackbufferSurface, srcRect, DDBLT_WAIT)

End Sub


Private Sub Command1_Click()
MaMode = True
Enemy1Mode = False
MapMode = False
Ma_Date.CurPosX = 0
Ma_Date.CurPosY = 0
End Sub

Private Sub Command2_Click()
Tile.Show
Tile.Label1.Caption = Editor.Label1.Caption
Picture1.Enabled = False

End Sub



Private Sub Command3_Click()
Enemy1Mode = True
MaMode = False
MapMode = False
Enemy1Num = 10
Dim i As Integer
For i = 0 To 9
    Enemy1_Date(i).CurPosX = 0
    Enemy1_Date(i).CurPosY = 0
Next i
End Sub

Private Sub Command4_Click()
MapMode = True
MaMode = False
Enemy1Mode = False

End Sub

Private Sub Form_Load()
InitDDraw
InitSurface
InitSystemDate
InitNormalDate


End Sub

Private Sub Picture1_Click()
Dim i As String

If MaMode = False And Enemy1Mode = False And MapMode = False Then
    Tile_Date(Int(CurMousePosX / TileSize), Int(CurMousePosY / TileSize)).GraphyIndex = GraphyIndex
    Tile_Date(Int(CurMousePosX / TileSize), Int(CurMousePosY / TileSize)).Pass = Pass
    
End If

If MaMode = True Then
    With Ma_Date
    .CurPosX = Int(CurMousePosX / TileSize)
    .CurPosY = Int(CurMousePosY / TileSize)
    End With
    MaMode = False
End If

If MapMode = True Then
    i = InputBox(i)
    Tile_Date(Int(CurMousePosX / TileSize), Int(CurMousePosY / TileSize)).MapIndex = Val(i)
    MapMode = False


End If

If Enemy1Mode = True Then

    With Enemy1_Date(Enemy1Num - 1)
        .CurPosX = Int(CurMousePosX / TileSize)
        .CurPosY = Int(CurMousePosY / TileSize)
    End With
    
    Enemy1Num = Enemy1Num - 1
    If Enemy1Num = 0 Then Enemy1Mode = False
    
End If

Call refresh_Click
End Sub

Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
CurMousePosX = X
CurMousePosY = Y
If MaMode = False And Enemy1Mode = False And MapMode = False Then

    If Button = 1 Then
        Tile_Date(Int(CurMousePosX / TileSize), Int(CurMousePosY / TileSize)).GraphyIndex = GraphyIndex
        Tile_Date(Int(CurMousePosX / TileSize), Int(CurMousePosY / TileSize)).Pass = Pass
        Call refresh_Click
    End If
End If
End Sub

Private Sub refresh_Click()
PaintBackground
PaintMa
PaintEnemy1
PaintMap
PaintToScreen
End Sub

Private Sub Save_Click()

SaveMap

End Sub
Private Sub Open_Click()

LoadMap

Call refresh_Click

End Sub
Sub LoadMap()
Dim Fileno As Integer
Fileno = FreeFile
Open "map1.dat" For Binary As Fileno
Get #Fileno, , Tile_Date
Get #Fileno, , Ma_Date
Get #Fileno, , Enemy1_Date
Close #Fileno

End Sub
Sub SaveMap()
Dim Fileno As Integer
Fileno = FreeFile
Open "map1.dat" For Binary As Fileno
Put #Fileno, , Tile_Date
Put #Fileno, , Ma_Date
Put #Fileno, , Enemy1_Date
Close #Fileno
End Sub