www.pudn.com > Vb3d.zip > voxel.frm
VERSION 5.00
Begin VB.Form Form1
Caption = "Voxel"
ClientHeight = 3675
ClientLeft = 60
ClientTop = 345
ClientWidth = 4815
KeyPreview = -1 'True
LinkTopic = "Form1"
ScaleHeight = 3675
ScaleWidth = 4815
StartUpPosition = 3 'Windows Default
Begin VB.PictureBox Pictxt
AutoRedraw = -1 'True
AutoSize = -1 'True
Height = 1440
Left = 1920
ScaleHeight = 92
ScaleMode = 3 'Pixel
ScaleWidth = 84
TabIndex = 2
Top = 210
Visible = 0 'False
Width = 1320
End
Begin VB.PictureBox Pichgt
AutoRedraw = -1 'True
AutoSize = -1 'True
Height = 1695
Left = 1770
ScaleHeight = 109
ScaleMode = 3 'Pixel
ScaleWidth = 112
TabIndex = 1
Top = 120
Visible = 0 'False
Width = 1740
End
Begin VB.PictureBox Pic
AutoSize = -1 'True
Height = 1560
Left = 0
ScaleHeight = 100
ScaleMode = 3 'Pixel
ScaleWidth = 96
TabIndex = 0
Top = 0
Width = 1500
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim tmpScaleY
Dim tmpScaleX
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 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 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
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC 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 dwRop As Long) As Long
Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
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
Sub DrawFrame()
'***********************************
' Setup the bitmaps so we can
' get to their memory
'***********************************
' these are used to address the pixel using matrices
Dim pict() As Byte
Dim pict2() As Byte
Dim pict3() As Byte
Dim sa As SAFEARRAY2D, bmp As BITMAP
Dim sa2 As SAFEARRAY2D, bmp2 As BITMAP
Dim sa3 As SAFEARRAY2D, bmp3 As BITMAP
Dim r As Integer, c As Integer
' get bitmap info
GetObjectAPI Pic.Picture, Len(bmp), bmp 'picture
GetObjectAPI Pictxt.Picture, Len(bmp2), bmp2 'texture
GetObjectAPI Pichgt.Picture, Len(bmp3), bmp3 'height map
' exit if not a supported bitmap
If bmp.bmBitsPixel <> 8 Then
MsgBox " 8-bit bitmaps only", vbCritical
Exit Sub
End If
' have the local matrix point to bitmap pixels
With sa
.cbElements = 1
.cDims = 2
.Bounds(0).lLbound = 0
.Bounds(0).cElements = bmp.bmHeight
.Bounds(1).lLbound = 0
.Bounds(1).cElements = bmp.bmWidthBytes
.pvData = bmp.bmBits
End With
CopyMemory ByVal VarPtrArray(pict), VarPtr(sa), 4
' have the local matrix point to bitmap pixels
With sa2
.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(pict2), VarPtr(sa2), 4
' have the local matrix point to bitmap pixels
With sa3
.cbElements = 1
.cDims = 2
.Bounds(0).lLbound = 0
.Bounds(0).cElements = bmp3.bmHeight
.Bounds(1).lLbound = 0
.Bounds(1).cElements = bmp3.bmWidthBytes
.pvData = bmp3.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 = 0
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 >= 239) 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
'***********************************
' Clean up the bitmaps
'***********************************
' 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
End Sub
Private Sub Form_Load()
Pic.Picture = LoadPicture(App.Path & "\title.gif")
Pictxt.Picture = LoadPicture(App.Path & "\texture.gif")
Pichgt.Picture = LoadPicture(App.Path & "\height.gif")
'set up the default starting positions
vp_z = 500: vp_x = 200: vp_y = 200
dslope = 0.05
raycast_ang = 100
tmpScaleX = 0
tmpScaleY = 0
End Sub
Private Sub Form_Unload(Cancel As Integer)
exitflag = True
End Sub
Private Sub Pic_KeyDown(KeyCode As Integer, Shift As Integer)
Me.Caption = KeyCode
Select Case KeyCode
Case 38
tmpScaleX = -10
tmpScaleY = 0
Case 39
tmpScaleX = 0
tmpScaleY = -10
Case 40
tmpScaleX = 10
tmpScaleY = 0
Case 37
tmpScaleX = 0
tmpScaleY = 10
End Select
vp_y = vp_y - tmpScaleY
vp_x = vp_x - tmpScaleX
DrawFrame
Pic.Refresh
End Sub