frmmap1.frm

一个RPG游戏源代码

      Picture         =   "frmmap1.frx":256D21
      Top             =   0
      Visible         =   0   'False
      Width           =   720
   End
End
Attribute VB_Name = "frmmap1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'RPG游戏引擎

'附:障碍物为image1 , 实体为imgnpc,如要增加请复制
'每张地图规格为 1024*768 ,不要改变!
'这是一个场景,如果要增加场景请新建窗体,并将原码复制过去.把窗体的keypreview属性改为true,windowstyle属性改为 2-Max
'如有疑问请与我联系

Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Dim Running As Boolean 'Is the game running
Dim CurOption As Integer 'Used for setting the DDSIcon position
Dim Background As DirectDrawSurface7 'This holds are background bitmap
Dim BGRect As RECT 'the rect for the BG
Dim DDSIcon As DirectDrawSurface7 'This holds are background bitmap
Dim IconRect As RECT 'the rect for the BG
Dim MouseDown As Boolean 'is the mouse down?
Private Type POINTAPI
        X As Long
        Y As Long
End Type
Dim CURSORPOS As POINTAPI
'///////////////////////////////////Directx设置
Const key_up = 38
Const key_down = 40
Const key_left = 37
Const key_right = 39
Const key_exit = 27
Const key_black = 32
Const key_enter = 13
'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\按键Ascii码 *
Const walkspeet = 1                 '人物行走速度,单位像素
Const wallnum = 3                   '障碍物数量
Const npcnum = 4                    '实体数量
Dim whichthings As String           '物品名称变量 *
Dim walknum As Integer
Dim ui As Integer
Dim di As Integer
Dim a As Integer
Dim witch As Integer
Dim i As Integer
Dim ii As Integer
Dim camera As String
Dim talknumber As Integer
Dim walk As String
'//////////////////////////////////控制变量声明

Private Sub Form_Load()
    InitDirectDraw frmmap1, 640, 480, 16             '控制窗体进入全屏模式，更换窗体时要把frmmap1改成希望更换的窗体名称，640*480为分辨率，16为颜色
    camera = "off"                                   '人物是否可以移动，"on"可以,"off"不可以
    ui = -1                                          '初始化 *
    walknum = 1                                      '初始化 *
    talknumber = 0                                   '初始化 *
    picmap.Left = 0                                  '初始化地图坐标（水平）
    picmap.Top = 0                                   '初始化地图坐标（垂直）
    picbar1.Left = 160: picbar1.Top = 120            '初始化消息框坐标
    picbar3.Left = 0: picbar3.Top = 390              '初始化对话框坐标
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
'//////////////////////////////////键盘事件，人物移动 *
If camera <> "on" Then

    Select Case KeyCode
    Case key_up
        txtwalk.Text = "u"
        Timer1.Enabled = True

    Case key_down
        txtwalk.Text = "d"
        Timer1.Enabled = True

    Case key_left
        txtwalk.Text = "l"
        Timer1.Enabled = True

    Case key_right
        txtwalk.Text = "r"
        Timer1.Enabled = True

    End Select

End If
End Sub

Private Sub tmrjiantou_Timer()         '通过时钟激发事件,如果激发事件不是通过和某物体对话发生,那么可以使用此方法
Select Case frmstate.lblmission.Caption
    Case "情节1":

    End Select
End Sub

Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)

    Select Case KeyCode
    Case key_exit                    '当按下ESC时
        End
    Case key_up                      '当按下控制键上时
        Timer1.Enabled = False
    Case key_down
        Timer1.Enabled = False       '当按下控制键下时
    Case key_left
        Timer1.Enabled = False
    Case key_right                   '当按下控制键右时
        Timer1.Enabled = False
    Case key_black:                  '当按下空各键时
     '\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
    If ui <> -1 Then                            '拾获物品,人物对话..或通过拾获物品和人物对话激发事件
        Select Case ui                          '在ui这个实体上按下空格间所发生的事件(ui为imgnpc()的索引)
            Case 0  '和 imgnpc(0)这个实体说话,同时触发的事件 (&&&&&)
                If frmstate.lblmission.Caption = "情节1" Then
                talknumber = talknumber + 1
                talknumber = 0
                picbar3.Visible = True
                lbltalk1.Caption = "Hunter：我走了。"
                frmstate.lblmission.Caption = "情节2"
                End If

            Case 1 '和 imgnpc(1)这个实体说话
                talknumber = talknumber + 1
                picbar3.Visible = True
                If talknumber = 1 Then lbltalk1.Caption = "三维空间：暗号地带无限精彩。"
                If talknumber = 2 Then picbar3.Visible = False: talknumber = 0
            
            Case 2 '和 imgnpc(2)这个实体说话
                talknumber = talknumber + 1
                picbar3.Visible = True
                If talknumber = 1 Then lbltalk1.Caption = "邹本辉：希望做最好的游戏　。"
                If talknumber = 2 Then picbar3.Visible = False: talknumber = 0
            
            Case 3 '拾获imgnpc(3)这个实体,物品的功能请在 frmitem 窗体里编写
                whichthings = "恢复剂1"
                getitems
        End Select
    End If
    
    '\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
    Select Case frmstate.lblmission.Caption     '如果已经触发某对话可以按空格键继续。触发事件自己编
        Case "情节2":                           '事件 (&&&&&) 这个事件使imgnpc(0)消失
        talknumber = talknumber + 1
        If talknumber = 1 Then lbltalk1.Caption = "主角：88!"
        If talknumber = 2 Then imgnpc(0).Visible = False
        If talknumber = 3 Then picbar3.Visible = False: talknumber = 0: frmstate.lblmission.Caption = "情节3"
    End Select
    '\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
End Select

End Sub

Private Sub picbutton_Click(Index As Integer) '\\\\\\\\\\\\\\\\\\\\\按钮
Select Case Index
    Case 0: Load frmstate: frmstate.Show: frmstate.lblfrm.Caption = "frmmap1": Me.Hide
    Case 1: Load frmitem: frmitem.Show: frmitem.lblfrm.Caption = "frmmap1": Me.Hide
End Select
End Sub

Private Sub picmap_Click()

End Sub

Private Sub Timer1_Timer() '\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\行走\地图移动 *
Select Case txtwalk.Text
    Case "u"
    ui = outWall(imgnpc, npcnum, imgme.Left, imgme.Top - walkspeet, imgme.Width, imgme.Height)
    di = outWall(Image1, wallnum, imgme.Left, imgme.Top - walkspeet, imgme.Width, imgme.Height)
    If di = -1 Then imgme.Top = imgme.Top - walkspeet: If imgme.Top < 472 And picmap.Top < 0 Then picmap.Top = picmap.Top + walkspeet

    Case "d"
    ui = outWall(imgnpc, npcnum, imgme.Left, imgme.Top + walkspeet, imgme.Width, imgme.Height)
    di = outWall(Image1, wallnum, imgme.Left, imgme.Top + walkspeet, imgme.Width, imgme.Height)
    If di = -1 Then imgme.Top = imgme.Top + walkspeet: If imgme.Top > 220 And picmap.Top > -288 Then picmap.Top = picmap.Top - walkspeet

    Case "l"
    ui = outWall(imgnpc, npcnum, imgme.Left - walkspeet, imgme.Top, imgme.Width, imgme.Height)
    di = outWall(Image1, wallnum, imgme.Left - walkspeet, imgme.Top, imgme.Width, imgme.Height)
    If di = -1 Then imgme.Left = imgme.Left - walkspeet: If imgme.Left <= 696 And picmap.Left < 0 Then picmap.Left = picmap.Left + walkspeet

    Case "r"
    ui = outWall(imgnpc, npcnum, imgme.Left + walkspeet, imgme.Top, imgme.Width, imgme.Height)
    di = outWall(Image1, wallnum, imgme.Left + walkspeet, imgme.Top, imgme.Width, imgme.Height)
    If di = -1 Then imgme.Left = imgme.Left + walkspeet: If imgme.Left >= 320 And picmap.Left >= -375 Then picmap.Left = picmap.Left - walkspeet
End Select
'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
walknum = walknum + 1: If walknum = 4 Then walknum = 1             '走路动画 *
Select Case walknum
Case 1: imgme.Picture = imgmove1.Picture
Case 2: imgme.Picture = imgmove2.Picture
Case 3: imgme.Picture = imgmove3.Picture
End Select
'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
    If di <> -1 Then                 '通过碰撞障碍物激发事件
        Select Case di               '碰撞di所发生的事件(di为image1()的索引)
            Case 2: End              '碰撞障碍 image1(2) 发生的事件,使程序结束
        End Select
    End If
'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
End Sub

Private Sub txtwalk_Change() ''\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\不同方向的不同动画
Select Case txtwalk.Text
    Case "u"
        imgmove1.Picture = LoadPicture(App.Path + "\modle\player\playup1.ico")
        imgmove2.Picture = LoadPicture(App.Path + "\modle\player\playup2.ico")
        imgmove3.Picture = LoadPicture(App.Path + "\modle\player\playup3.ico")
    Case "d"
        imgmove1.Picture = LoadPicture(App.Path + "\modle\player\playdown1.ico")
        imgmove2.Picture = LoadPicture(App.Path + "\modle\player\playdown2.ico")
        imgmove3.Picture = LoadPicture(App.Path + "\modle\player\playdown3.ico")
    Case "l"
        imgmove1.Picture = LoadPicture(App.Path + "\modle\player\playleft1.ico")
        imgmove2.Picture = LoadPicture(App.Path + "\modle\player\playleft2.ico")
        imgmove3.Picture = LoadPicture(App.Path + "\modle\player\playleft3.ico")
    Case "r"
        imgmove1.Picture = LoadPicture(App.Path + "\modle\player\playright1.ico")
        imgmove2.Picture = LoadPicture(App.Path + "\modle\player\playright2.ico")
        imgmove3.Picture = LoadPicture(App.Path + "\modle\player\playright3.ico")
End Select
End Sub

Private Sub stopwalk() ''\\\\\\\\\\\\\\\\\\\\\\\\停止走路 *
rightwalk = "": leftwalk = "": upwalk = "": downwalk = ""
End Sub

Private Sub text1_Change() '\\\\\\\\\\\\\\\\\\\\\文字阴影 *
text2.Caption = text1.Caption
End Sub

Private Sub lbltalk1_Change() '\\\\\\\\\\\\\\\\\\文字阴影 *
lbltalk2.Caption = lbltalk1.Caption
End Sub

Private Sub Picture3_Click()
Picture1.Visible = False
End Sub

Private Sub getitems() ''\\\\\\\\\\\\\\\\\\\\\\\\\拾获物品 *
        For i = 0 To 9
        If frmitem.lblitem(i).Caption = "" Then
            If frmitem.lblitem(i).Caption = "" Then frmitem.lblitem(i).Caption = whichthings: frmitem.imgitem(i).Picture = imgnpc(ui).Picture: imgnpc(ui).Visible = False: imgnpc(ui).Left = -10000: ui = -1: GoTo 2
        End If
        Next
2 End Sub

Private Function outWall(wall As Object, wallnum As Integer, l As Integer, t As Integer, w As Integer, h As Integer) As Integer
''\\\\\\\\\\\\\\\\\\障碍物 *
    On Error Resume Next
    Dim i As Integer
    outWall = -1
    For i = 0 To wallnum - 1
    If (wall(i).Left < l + w) And (wall(i).Left + wall(i).Width > l) And (wall(i).Top + wall(i).Height > t) And (wall(i).Top < t + h) Then
    outWall = i
    Exit For
    End If
    Next
End Function