www.pudn.com > Vb3d.zip > voxel_dx.frm
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%
'ShowCursor 0
' Create the DirectDraw object
DirectDrawCreate ByVal 0&, dd, Nothing
' This app is full screen and will change the display mode
dd.SetCooperativeLevel Me.hwnd, DDSCL_EXCLUSIVE Or DDSCL_FULLSCREEN Or DDSCL_ALLOWMODEX
' Set the display mode
dd.SetDisplayMode ResolutionX, ResolutionY, 8, 0, 0
'load bitmaps
Picture1.Picture = LoadPicture(App.Path & "\texture.gif")
Picture2.Picture = LoadPicture(App.Path & "\height.gif")
' Fill front buffer description structure...
With ddsdFront
' Structure size
.dwSize = Len(ddsdFront)
' Use DDSD_CAPS and BackBufferCount
.dwFlags = DDSD_CAPS Or DDSD_BACKBUFFERCOUNT
' Primary, flipable surface
.DDSCAPS.dwCaps = DDSCAPS_PRIMARYSURFACE Or DDSCAPS_FLIP Or DDSCAPS_COMPLEX Or DDSCAPS_SYSTEMMEMORY
' One back buffer (you can try 2)
.dwBackBufferCount = 1
End With
' Create front buffer
dd.CreateSurface ddsdFront, ddsFront, Nothing
' Retrieve the back buffer object
ddCaps.dwCaps = DDSCAPS_BACKBUFFER
ddsFront.GetAttachedSurface ddCaps, ddsBack
'Read palette from .PAL file
'p.s. most paint programs import and export RIFF
'palettes in this format
Open App.Path & "\voxel.pal" For Random As 1 Len = 1
For a% = 0 To 255
Get #1, (a% * 4) + 25, gpals(a%).peRed
Get #1, (a% * 4) + 26, gpals(a%).peGreen
Get #1, (a% * 4) + 27, gpals(a%).peBlue
Next
Close
'set palette
dd.CreatePalette DDPCAPS_8BIT, gpals(0), lpDDpalette, Nothing
ddsFront.SetPalette lpDDpalette
b1.Top = 0: b1.Left = 0
b1.Right = 319: b1.Bottom = 239
'Render loop
While Not blnend
u& = GetCursorPos(ps)
'reposition based on mouse
vp_x = vp_x - (ps.x - 160) / 10
vp_y = vp_y - (ps.y - 120) / 10
DRAWNEXTFRAME
u = DoEvents
Wend
'clean up
' Set pDDs = Nothing
dd.FlipToGDISurface
dd.RestoreDisplayMode
dd.SetCooperativeLevel 0, DDSCL_NORMAL
Set ddsBack = Nothing
Set lpDDpalette = Nothing
Set ddsFront = Nothing
Set dd = Nothing
'ShowCursor 1
Unload Voxel_dx
End Sub
Private Sub Form_KeyPress(KeyAscii As Integer)
blnend = True
End Sub
Sub DRAWNEXTFRAME()
' these are used to address the pixel using matrices
'dim pos As Integer
ddsd.dwFlags = DDSD_ALL
ddsd.dwSize = Len(ddsd)
' get bitmap info
ddsBack.GetSurfaceDesc ddsd
b1.Top = 0: b1.Left = 0
b1.Right = ddsd.dwWidth
b1.Bottom = ddsd.dwHeight
GetObjectAPI Picture1.Picture, Len(bmp1), bmp1 'texture
GetObjectAPI Picture2.Picture, Len(bmp2), bmp2 'height map
'lock
ddsBack.Lock b1, ddsd, DDLOCK_WAIT, ByVal 0&
' have the local matrix point to DDSBack
With sa
.cbElements = 1
.cDims = 2
.Bounds(0).lLbound = 0
.Bounds(0).cElements = ddsd.dwHeight
.Bounds(1).lLbound = 0
.Bounds(1).cElements = ddsd.dwWidth
.pvData = ddsd.lpSurface
End With
CopyMemory ByVal VarPtrArray(pict), VarPtr(sa), 4
' have the local matrix point to texture
With sa2
.cbElements = 1
.cDims = 2
.Bounds(0).lLbound = 0
.Bounds(0).cElements = bmp1.bmHeight
.Bounds(1).lLbound = 0
.Bounds(1).cElements = bmp1.bmWidthBytes
.pvData = bmp1.bmBits
End With
CopyMemory ByVal VarPtrArray(pict2), VarPtr(sa2), 4
' have the local matrix point to height map
With sa3
.cbElements = 1
.cDims = 2
.Bounds(0).lLbound = 0
.Bounds(0).cElements = bmp2.bmHeight
.Bounds(1).lLbound = 0
.Bounds(1).cElements = bmp2.bmWidthBytes
.pvData = bmp2.bmBits
End With
CopyMemory ByVal VarPtrArray(pict3), VarPtr(sa3), 4
'***********************************
' Here is where we draw a frame
'***********************************
For c = 0 To 319
For r = 0 To 239
pict(c, r) = 0
Next
Next
'**********************************************************
'Thanks to Andre' LaMothe for the C source code this Voxel
'demonstration is based on. David Brebner 24/1/98
'**********************************************************
For c = 0 To SCREEN_WIDTH 'cast a ray for each column of the screen
' seed starting point for cast
x_ray = vp_x
y_ray = vp_y
z_ray = vp_z
' compute deltas to project ray at, note the spherical cancelation factor
dx = Cos((raycast_ang + c) / 360)
dy = Sin((raycast_ang + c) / 360)
' dz is a bit complex, remember dz is the slope of the ray we are casting
' therefore, we need to take into consideration the down angle, or
' x axis angle, the more we are looking down the larger the intial dz
' must be
dz = dslope * -100
' reset current voxel scale
curr_voxel_scale = 0
' reset row
curr_row = 239
For curr_step = 0 To MAX_STEPS ' enter into casting loop
xr = x_ray And 511 'trim
yr = y_ray And 511 'trim
' get current height in height map
' and the added multiplication factor used to scale the mountains
column_height = pict3(xr, yr) * 2
'test if column height is greater than current voxel height for current step
'from intial projection point
If column_height > z_ray Then
' we know that we have intersected a voxel column, therefore we must
' render it until we have drawn enough pixels on the display such that
' thier projection would be correct for the height of this voxel column
' or until we have reached the top of the screen
' get the color for the voxel
color = pict2(xr, yr)
' draw vertical column voxel
Do
' draw a pixel
pict(c, curr_row) = color
' now we need to push the ray upward on z axis, so increment the slope
dz = dz + dslope
' now translate the current z position of the ray by the current voxel
' scale per unit
z_ray = z_ray + curr_voxel_scale
' test if we are done with column
curr_row = curr_row - 1
If (curr_row <= 0) Then
' force exit of outer steping loop
curr_step = MAX_STEPS
Exit Do
End If
Loop Until z_ray > column_height
End If
' update the position of the ray
x_ray = x_ray + dx
y_ray = y_ray + dy
z_ray = z_ray + dz
' update the current voxel scale, remember each step out means the scale increases
' by the delta scale
curr_voxel_scale = curr_voxel_scale + dslope * 0.5
Next
Next
' clear the temporary array descriptor
' without destroying the local temporary array
CopyMemory ByVal VarPtrArray(pict), 0&, 4
CopyMemory ByVal VarPtrArray(pict2), 0&, 4
CopyMemory ByVal VarPtrArray(pict3), 0&, 4
ddsBack.Unlock ByVal 0&
' Flip the buffers
Do
ddsFront.Flip Nothing, 0
If Err.Number = DDERR_SURFACELOST Then ddsFront.Restore
Loop Until Err.Number = 0
End Sub
Private Sub Form_Load()
'set up the default starting positions
vp_z = 500: vp_x = 200: vp_y = 200
dslope = 0.05
raycast_ang = 100
End Sub