voxel_dx.frm

Deleta Force 引擎的雏形

VERSION 5.00
Begin VB.Form Voxel_dx 
   Caption         =   "Voxel Demo"
   ClientHeight    =   1725
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   5715
   KeyPreview      =   -1  'True
   LinkTopic       =   "Form1"
   ScaleHeight     =   1725
   ScaleWidth      =   5715
   StartUpPosition =   3  'Windows Default
   Begin VB.PictureBox Picture2 
      AutoSize        =   -1  'True
      Height          =   135
      Left            =   7005
      ScaleHeight     =   75
      ScaleWidth      =   90
      TabIndex        =   2
      Top             =   120
      Width           =   150
   End
   Begin VB.PictureBox Picture1 
      AutoSize        =   -1  'True
      Height          =   135
      Left            =   7005
      ScaleHeight     =   75
      ScaleWidth      =   90
      TabIndex        =   1
      Top             =   330
      Width           =   150
   End
   Begin VB.CommandButton Command1 
      Caption         =   "Click To Start"
      Height          =   345
      Left            =   120
      TabIndex        =   0
      Top             =   135
      Width           =   1410
   End
   Begin VB.Label Label2 
      Caption         =   "This Demo require Patrice Scribes DX5 Type library files."
      Height          =   615
      Left            =   1650
      TabIndex        =   4
      Top             =   945
      Width           =   3735
   End
   Begin VB.Label Label1 
      Caption         =   "Voxel demo by David Brebner, Unlimited Realities http://erdc-pc8.massey.ac.nz  This is based on source code by Andre' LaMothe."
      Height          =   675
      Left            =   1650
      TabIndex        =   3
      Top             =   180
      Width           =   3780
   End
End
Attribute VB_Name = "Voxel_dx"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
' Transparent Blit
Option Compare Text
Option Explicit
Dim b1 As RECT, b2 As RECT, b3 As RECT
Dim u As Long

Dim blnend As Boolean

Private Type SAFEARRAYBOUND
    cElements As Long
    lLbound As Long
End Type

Private Type SAFEARRAY1D
    cDims As Integer
    fFeatures As Integer
    cbElements As Long
    cLocks As Long
    pvData As Long
    Bounds(0 To 0) As SAFEARRAYBOUND
End Type

Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type

Private Type SAFEARRAY2D
    cDims As Integer
    fFeatures As Integer
    cbElements As Long
    cLocks As Long
    pvData As Long
    Bounds(0 To 1) As SAFEARRAYBOUND
End Type

Private Declare Function VarPtrArray Lib "msvbvm50.dll" Alias "VarPtr" (Ptr() As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long


' Win32
Private gpals(255) As PALETTEENTRY
Private Declare Function GetPaletteEntries Lib "gdi32" (ByVal hPalette As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long


Const IMAGE_BITMAP = 0
Const LR_LOADFROMFILE = &H10
Const LR_CREATEDIBSECTION = &H2000
Const SRCCOPY = &HCC0020

Private Type PALETTEENTRY
        peRed As Byte
        peGreen As Byte
        peBlue As Byte
        peFlags As Byte
End Type

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 GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
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 ShowCursor Lib "user32" (ByVal bShow As Long) As Long

Const ResolutionX = 320     ' Width for the display mode
Const ResolutionY = 240     ' Height for the display mode

Dim dd As DirectDraw2               ' DirectDraw object
Dim ddsdFront As DDSURFACEDESC      ' Front surface description
Dim ddsFront As DirectDrawSurface2  ' Front buffer
Dim ddsBack As DirectDrawSurface2   ' Back buffer
Dim lpDDpalette As DirectDrawPalette 'hold the palette
'Dim pDDs As DirectDrawSurface2

Dim ddCaps As DDSCAPS               ' Capabilities for search

Private Type POINTAPI
        x As Long
        y As Long
End Type
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long

Private pict() As Byte
Private pict2() As Byte
Private pict3() As Byte
    
Private xdelta As Integer, ydelta As Integer
Private ly As Integer, lx As Integer, xtemp As Integer, ytemp As Integer
    
Private sa As SAFEARRAY2D, ddsd As DDSURFACEDESC
Private sa2 As SAFEARRAY2D, bmp1 As BITMAP
Private sa3 As SAFEARRAY2D, bmp2 As BITMAP
Private r As Integer, c As Integer, nc As Integer
    
Private ps As POINTAPI, ret&

Dim fx As DDBLTFX

Private Const SCREEN_WIDTH = 319
Private Const SCREEN_HEIGHT = 239
Private Const MAX_STEPS = 300

Dim x_ray As Double, y_ray As Double, z_ray As Double
Dim vp_x As Double, vp_y As Double, vp_z As Double
Dim vp_ang_x As Double, xr As Double, yr As Double
Dim curr_row As Integer, curr_step As Integer, curr_voxel_scale As Double
Dim dslope As Double, raycast_ang As Integer
Dim column_height As Double, color As Byte

Dim mx As Integer, my As Integer
Dim exitflag As Boolean
Dim dx As Double, dy As Double, dz As Double

' Loads a bitmap in a DirectDraw surface
Private Function CreateDDSFromBitmap(dd As DirectDraw2, ByVal strFile As String) As DirectDrawSurface2
    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
    Dim mhdc As Long                ' Handle on surface context
    Dim clr As Long                 'hold the colour top left to be made transparent
    ' Load bitmap
    hbm = LoadImage(ByVal 0&, strFile, IMAGE_BITMAP, 0, 0, LR_LOADFROMFILE Or LR_CREATEDIBSECTION)
    ' Get bitmap info
    GetObject hbm, Len(bm), bm
    ' Fill surface description
    With ddsd
        .dwSize = Len(ddsd)
        .dwFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH
        .DDSCAPS.dwCaps = DDSCAPS_OFFSCREENPLAIN
        .dwWidth = bm.bmWidth
        .dwHeight = bm.bmHeight
    End With
    ' Create surface
    dd.CreateSurface ddsd, dds, Nothing
    ' Create memory device
    hdcImage = CreateCompatibleDC(ByVal 0&)
    ' Select the bitmap in this memory device
    SelectObject hdcImage, hbm
    ' Restore the surface
    dds.Restore
    ' Get the surface's DC
    dds.GetDC mhdc
    ' Copy from the memory device to the DirectDrawSurface
    StretchBlt mhdc, 0, 0, ddsd.dwWidth, ddsd.dwHeight, hdcImage, 0, 0, bm.bmWidth, bm.bmHeight, SRCCOPY
    'get the top left colour
    clr = GetPixel(mhdc, 0, 0)
    ' Release the surface's DC
    dds.ReleaseDC mhdc
    ' Release the memory device and the bitmap
    DeleteDC hdcImage
    DeleteObject hbm
    
    'make surface transparent
    Dim mhddck As DDCOLORKEY
    mhddck.dwColorSpaceLowValue = clr 'really works only for 24 bit colour
    mhddck.dwColorSpaceHighValue = clr 'but as sprites have black is all 0 at any rate
    dds.SetColorKey DDCKEY_SRCBLT, mhddck
    
    ' Returns the new surface
    Set CreateDDSFromBitmap = dds
End Function




Private Sub Command1_Click()
    Command1.Enabled = 0
    Dim a%, g$, bi%