frmdemox.frm

由于这是本人近一年前初学vb时的作品

VERSION 5.00
Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "COMCTL32.OCX"
Begin VB.Form frmTestX 
   Caption         =   "DirectX Test"
   ClientHeight    =   3495
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   6795
   LinkTopic       =   "Form1"
   ScaleHeight     =   3495
   ScaleWidth      =   6795
   StartUpPosition =   3  'Windows Default
   Begin VB.PictureBox picHidden 
      Appearance      =   0  'Flat
      AutoRedraw      =   -1  'True
      BackColor       =   &H80000005&
      BorderStyle     =   0  'None
      ForeColor       =   &H80000008&
      Height          =   480
      Left            =   120
      ScaleHeight     =   32
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   32
      TabIndex        =   0
      Top             =   1200
      Visible         =   0   'False
      Width           =   480
   End
   Begin VB.Timer tmrMain 
      Enabled         =   0   'False
      Interval        =   20
      Left            =   120
      Top             =   120
   End
   Begin ComctlLib.ImageList imlFloorTiles 
      Left            =   720
      Top             =   600
      _ExtentX        =   1005
      _ExtentY        =   1005
      BackColor       =   -2147483643
      ImageWidth      =   32
      ImageHeight     =   32
      MaskColor       =   12632256
      UseMaskColor    =   0   'False
      _Version        =   327682
      BeginProperty Images {0713E8C2-850A-101B-AFC0-4210102A8DA7} 
         NumListImages   =   3
         BeginProperty ListImage1 {0713E8C3-850A-101B-AFC0-4210102A8DA7} 
            Picture         =   "frmDemoX.frx":0000
            Key             =   ""
         EndProperty
         BeginProperty ListImage2 {0713E8C3-850A-101B-AFC0-4210102A8DA7} 
            Picture         =   "frmDemoX.frx":0C52
            Key             =   ""
         EndProperty
         BeginProperty ListImage3 {0713E8C3-850A-101B-AFC0-4210102A8DA7} 
            Picture         =   "frmDemoX.frx":18A4
            Key             =   ""
         EndProperty
      EndProperty
   End
   Begin ComctlLib.ImageList imlGuy 
      Left            =   120
      Top             =   600
      _ExtentX        =   1005
      _ExtentY        =   1005
      BackColor       =   -2147483643
      ImageWidth      =   48
      ImageHeight     =   48
      MaskColor       =   16777215
      _Version        =   327682
      BeginProperty Images {0713E8C2-850A-101B-AFC0-4210102A8DA7} 
         NumListImages   =   16
         BeginProperty ListImage1 {0713E8C3-850A-101B-AFC0-4210102A8DA7} 
            Picture         =   "frmDemoX.frx":24F6
            Key             =   ""
         EndProperty
         BeginProperty ListImage2 {0713E8C3-850A-101B-AFC0-4210102A8DA7} 
            Picture         =   "frmDemoX.frx":4048
            Key             =   ""
         EndProperty
         BeginProperty ListImage3 {0713E8C3-850A-101B-AFC0-4210102A8DA7} 
            Picture         =   "frmDemoX.frx":5B9A
            Key             =   ""
         EndProperty
         BeginProperty ListImage4 {0713E8C3-850A-101B-AFC0-4210102A8DA7} 
            Picture         =   "frmDemoX.frx":76EC
            Key             =   ""
         EndProperty
         BeginProperty ListImage5 {0713E8C3-850A-101B-AFC0-4210102A8DA7} 
            Picture         =   "frmDemoX.frx":923E
            Key             =   ""
         EndProperty
         BeginProperty ListImage6 {0713E8C3-850A-101B-AFC0-4210102A8DA7} 
            Picture         =   "frmDemoX.frx":AD90
            Key             =   ""
         EndProperty
         BeginProperty ListImage7 {0713E8C3-850A-101B-AFC0-4210102A8DA7} 
            Picture         =   "frmDemoX.frx":C8E2
            Key             =   ""
         EndProperty
         BeginProperty ListImage8 {0713E8C3-850A-101B-AFC0-4210102A8DA7} 
            Picture         =   "frmDemoX.frx":E434
            Key             =   ""
         EndProperty
         BeginProperty ListImage9 {0713E8C3-850A-101B-AFC0-4210102A8DA7} 
            Picture         =   "frmDemoX.frx":FF86
            Key             =   ""
         EndProperty
         BeginProperty ListImage10 {0713E8C3-850A-101B-AFC0-4210102A8DA7} 
            Picture         =   "frmDemoX.frx":11AD8
            Key             =   ""
         EndProperty
         BeginProperty ListImage11 {0713E8C3-850A-101B-AFC0-4210102A8DA7} 
            Picture         =   "frmDemoX.frx":1362A
            Key             =   ""
         EndProperty
         BeginProperty ListImage12 {0713E8C3-850A-101B-AFC0-4210102A8DA7} 
            Picture         =   "frmDemoX.frx":1517C
            Key             =   ""
         EndProperty
         BeginProperty ListImage13 {0713E8C3-850A-101B-AFC0-4210102A8DA7} 
            Picture         =   "frmDemoX.frx":16CCE
            Key             =   ""
         EndProperty
         BeginProperty ListImage14 {0713E8C3-850A-101B-AFC0-4210102A8DA7} 
            Picture         =   "frmDemoX.frx":18820
            Key             =   ""
         EndProperty
         BeginProperty ListImage15 {0713E8C3-850A-101B-AFC0-4210102A8DA7} 
            Picture         =   "frmDemoX.frx":1A372
            Key             =   ""
         EndProperty
         BeginProperty ListImage16 {0713E8C3-850A-101B-AFC0-4210102A8DA7} 
            Picture         =   "frmDemoX.frx":1BEC4
            Key             =   ""
         EndProperty
      EndProperty
   End
End
Attribute VB_Name = "frmTestX"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'RPG DirectX Scrolling and Animation Demo
'by Paul Pagel - [e-mail]
'1998 ver 1.0

Option Explicit

' DirectDraw Objects
Dim dDraw As IDirectDraw2 ' DirectDraw main object
Dim ddsPrimary As IDirectDrawSurface2 ' Primary surface (AKA Front Buffer)
Dim ddsBack1 As IDirectDrawSurface2 ' Back buffer (AKA Offscreen surface)
Dim ddsFloor As IDirectDrawSurface2
Dim ddsChars As IDirectDrawSurface2 'buffer to hold guy character animations
Dim ddsTiles As IDirectDrawSurface2 'floor tiles


Dim ddsd As DDSURFACEDESC ' Suface information
Dim ddc As DDSCAPS ' Device capabilities

Dim ClrKey As DDCOLORKEY

Dim miBaseX As Integer 'upper left corner map position
Dim miBaseY As Integer

Dim miDirX As Integer '-1, 0, 1 = left, none, right
Dim miDirY As Integer '-1, 0, 1 = up, none, down
Dim miStep As Integer '0 = stopped/completed, 1-8=walking
Dim meFaceDir As EDirection 'direction main char is facing

'key state vars
Dim mePendingDir As EDirection

Dim mbPendingUp    As Boolean
Dim mbPendingDown  As Boolean
Dim mbPendingLeft  As Boolean
Dim mbPendingRight As Boolean
Dim mbShowStats    As Boolean

Dim mbRunning As Boolean

Dim BPP As Long ' bits per pixel of the system

Private Sub Form_Activate()
    
    On Error GoTo ErrorActivate
    
    'main char initial position and facing direction
    miBaseX = 2
    miBaseY = 2
    meFaceDir = dirDown
    
    ChDir App.Path
    
    'get the map and tileset data
    If MMap.OpenMap(App.Path & "\DemoMap.map") Then
        Call FillTileBuffer
        Call FillFloorBuffer(miBaseX, miBaseY)
    End If
    
    mbRunning = True
    tmrMain.Enabled = True
    Exit Sub
    
ErrorActivate:
    MsgBox Err.Description, , "Form_Activate ERROR"
    Unload Me
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    
    Select Case KeyCode
        Case vbKeyDown
            mbPendingDown = True
            
        Case vbKeyUp
            mbPendingUp = True
            
        Case vbKeyLeft
            mbPendingLeft = True
            
        Case vbKeyRight
            mbPendingRight = True
                    
        Case vbKeySpace
            mbRunning = False 'end the demo
                    
        Case vbKeyS
            mbShowStats = True
            
    End Select
        
End Sub

Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
    
    Select Case KeyCode
            Case vbKeyDown
                mbPendingDown = False
                
            Case vbKeyUp
                mbPendingUp = False
            
            Case vbKeyLeft
               mbPendingLeft = False
               
            Case vbKeyRight
                mbPendingRight = False
                
            Case vbKeyS
                mbShowStats = False
                
        End Select
    
End Sub

Private Sub Form_Load()
    
    Dim dc As Long ' Desktop's device-context
    Dim i As Integer
    Dim hdcChar As Long
    
    dc = GetDC(0)
    ' get the bits per pixel of the user's system
    BPP = GetDeviceCaps(dc, BITSPIXEL)
    ' Release the dc by freeing any system resources
    Call ReleaseDC(0, dc)
    
    ' Full-Screen window without border & title bar
    SetWindowLong Me.hwnd, GWL_STYLE, WS_POPUP Or WS_VISIBLE
    
    ' Topmost Window
    SetWindowPos Me.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE
    
    ' Black color background
    Me.BackColor = Hex(RGB(0, 0, 0))
    
    ' Create a new DirectDraw object with the current
    ' display driver's GUID
    Call DirectDrawCreate(ByVal 0&, dDraw, Nothing)
    
    ' Set the FullScreen, Rebootable, Exclusive mode...
    Call dDraw.SetCooperativeLevel(Me.hwnd, DDSCL_EXCLUSIVE Or DDSCL_FULLSCREEN Or DDSCL_ALLOWREBOOT)
    
    ' Set display mode to 640x480 mode...
    Call dDraw.SetDisplayMode(640, 480, BPP, 0, 0)

    ' Now create a Front buffer
    With ddsd
        .dwSize = Len(ddsd)
        .dwFlags = DDSD_CAPS Or DDSD_BACKBUFFERCOUNT
        .DDSCAPS.dwCaps = DDSCAPS_PRIMARYSURFACE Or DDSCAPS_FLIP Or DDSCAPS_COMPLEX Or DDSCAPS_SYSTEMMEMORY
        ' Back buffer
        .dwBackBufferCount = 1
    End With
    
    ' Create the front buffer
    Call dDraw.CreateSurface(ddsd, ddsPrimary, Nothing)
    
    ' Fill out DDSCAPS struct
    ddc.dwCaps = DDSCAPS_BACKBUFFER
    
    ' Get the back buffer
    Call ddsPrimary.GetAttachedSurface(ddc, ddsBack1)
    'Call ddsPrimary.GetAttachedSurface(ddc, ddsBack2)
    
    'set up character buffer surface
    With ddsd
        .dwSize = Len(ddsd)
        .dwFlags = DDSD_CAPS Or DDSD_WIDTH Or DDSD_HEIGHT
        .DDSCAPS.dwCaps = DDSCAPS_OFFSCREENPLAIN Or DDSCAPS_SYSTEMMEMORY
        .dwWidth = 192
        .dwHeight = 192
    End With
    Call dDraw.CreateSurface(ddsd, ddsChars, Nothing)
    
    TwipsX = Screen.TwipsPerPixelX
    TwipsY = Screen.TwipsPerPixelY
    
    'set up the offscreen char buffer with images
    Dim iDir As Integer
    Dim iAnim As Integer
    Call ddsChars.GetDC(hdcChar)
    For i = 1 To imlGuy.ListImages.Count
        imlGuy.ListImages(i).Draw hdcChar, iAnim * 48 * TwipsX, iDir * 48 * TwipsY
        iAnim = iAnim + 1 'next animation cell
        If iAnim = 4 Then 'currently 4 animations per direction
            iDir = iDir + 1 'next direction (up,down,left,right)
            iAnim = 0       'first animation cell for the direction
        End If
    Next i
    Call ddsChars.ReleaseDC(hdcChar) 'don't forget to do this!
    
    
    'set up indexed tile buffer
    With ddsd
        .dwSize = Len(ddsd)
        .dwFlags = DDSD_CAPS Or DDSD_WIDTH Or DDSD_HEIGHT
        .DDSCAPS.dwCaps = DDSCAPS_OFFSCREENPLAIN Or DDSCAPS_SYSTEMMEMORY
        .dwWidth = 640  'holds up to 20 tiles - for now
        .dwHeight = 32
    End With
    Call dDraw.CreateSurface(ddsd, ddsTiles, Nothing)
    
    '// set up double-buffered floor surface //
    'Buffer has a two tile (64 pixel) border around
    'the 640x480 screen area.  New tiles are drawn to
    'the outer border in the direction the main character
    'is moving
    With ddsd
        .dwSize = Len(ddsd)
        .dwFlags = DDSD_CAPS Or DDSD_WIDTH Or DDSD_HEIGHT
        .DDSCAPS.dwCaps = DDSCAPS_OFFSCREENPLAIN Or DDSCAPS_SYSTEMMEMORY
        .dwWidth = 768  '64+640+64
        .dwHeight = 608 '64+480+64
    End With
    Call dDraw.CreateSurface(ddsd, ddsFloor, Nothing)
    
    'make white the transparent color for the chars buffer
    ClrKey.dwColorSpaceHighValue = RGB(255, 255, 255)
    ClrKey.dwColorSpaceLowValue = RGB(255, 255, 255)
    ddsChars.SetColorKey DDCKEY_SRCBLT, ClrKey
    
    'tmrMain.Enabled = True
    
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    
    If UnloadMode <> 1 Then ' Form_Unload event didn't occur
        ' Restore the display mode back...
        Call dDraw.RestoreDisplayMode
        Call dDraw.SetCooperativeLevel(0, DDSCL_NORMAL) ' Restore to normal screen
        
        ' Set the DirectDraw Objects to Nothing... VERY VERY IMPORTANT!
        Set ddsChars = Nothing
        Set ddsTiles = Nothing
        Set ddsFloor = Nothing
        Set ddsBack1 = Nothing   ' First release the back buffer
        Set ddsPrimary = Nothing ' And then release the front buffer
        Set dDraw = Nothing
        
        ' End the program
        End
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    
    ' Restore the display mode back...
    Call dDraw.RestoreDisplayMode
    Call dDraw.SetCooperativeLevel(0, DDSCL_NORMAL) ' Restore to normal screen
    
    ' Set the DirectDraw Objects to Nothing... VERY VERY IMPORTANT!
    Set ddsChars = Nothing   'character animation buffer
    Set ddsTiles = Nothing   'tile set buffer
    Set ddsFloor = Nothing   'scroll area buffer
    Set ddsBack1 = Nothing   'First release the back buffer
    Set ddsPrimary = Nothing 'And then release the front buffer
    Set dDraw = Nothing
    
    ' End the program
    End
End Sub


Private Sub tmrMain_Timer()
    
    On Error GoTo ErrorTimer
    Static bDrawing As Boolean
    
    If bDrawing Then Exit Sub
    bDrawing = True
    
    Dim rcBig As RECT
    Dim rcChar As RECT
    Dim lOffsetX As Integer