Direct X CODE 2

If D3Ddevice Is Nothing Then GoTo InitFailed

' Set rendering options

With D3Ddevice
.SetRenderState D3DRS_CULLMODE, D3DCULL_NONE
'.SetRenderState D3DRS_ZENABLE, D3DZB_TRUE ' enable z buffering
'.SetRenderState D3DRS_FILLMODE, 3 ' render solid polygons
'.SetRenderState D3DRS_LIGHTING, True ' enable lighting
.SetRenderState D3DRS_AMBIENT, vbWhite ' use ambient white light

End With
' Set the material properties
With Material.Ambient
.a = 1: .r = 1: .g = 1: .b = 1
End With

' Create a texture surface from a file
Set Texture = D3DX.CreateTextureFromFile(D3Ddevice, App.Path & "\texture.bmp")
' Check the pointer is valid
If Texture Is Nothing Then GoTo InitFailed

' Set the material and texture as the current ones to render from
D3Ddevice.SetMaterial Material
D3Ddevice.SetTexture 0, Texture

' Create a vertex buffer, using default usage and specifying enough memory for 24 vertices of format D3DFVF_VERTEX
Set VertexBuffer = D3Ddevice.CreateVertexBuffer(24 * Len(Vertex(1)), 0, D3DFVF_VERTEX, D3DPOOL_DEFAULT)
' Check pointer is valid
If VertexBuffer Is Nothing Then GoTo InitFailed

' Create an index buffer, using default uage and specifying enough memory for 36 16 bit integers
Set IndexBuffer = D3Ddevice.CreateIndexBuffer(36 * Len(Index(1)), 0, D3DFMT_INDEX16, D3DPOOL_DEFAULT)
' Check pointer is valid
If IndexBuffer Is Nothing Then GoTo InitFailed

' Now we make a cube shape out of our vetices
Vertex(1) = MakeVertex(-1, 1, -1, 0, 0, -1, 0, 0)
Vertex(2) = MakeVertex(1, 1, -1, 0, 0, -1, 1, 0)
Vertex(3) = MakeVertex(-1, -1, -1, 0, 0, -1, 0, 1)
Vertex(4) = MakeVertex(1, -1, -1, 0, 0, -1, 1, 1)
Vertex(5) = MakeVertex(1, 1, -1, 0, 0, 1, 0, 0)
Vertex(6) = MakeVertex(-1, 1, -1, 0, 0, 1, 1, 0)
Vertex(7) = MakeVertex(1, -1, -1, 0, 0, 1, 0, 1)
Vertex(8) = MakeVertex(-1, -1, -1, 0, 0, 1, 1, 1)

Vertex(9) = MakeVertex(-1, 1, 1, -1, 0, 0, 0, 0)
Vertex(10) = MakeVertex(-1, 1, -1, -1, 0, 0, 1, 0)
Vertex(11) = MakeVertex(-1, -1, 1, -1, 0, 0, 0, 1)
Vertex(12) = MakeVertex(-1, -1, -1, -1, 0, 0, 1, 1)
Vertex(13) = MakeVertex(1, 1, -1, 1, 0, 0, 0, 0)
Vertex(14) = MakeVertex(1, 1, 1, 1, 0, 0, 1, 0)
Vertex(15) = MakeVertex(1, -1, -1, 1, 0, 0, 0, 1)
Vertex(16) = MakeVertex(1, -1, 1, 1, 0, 0, 1, 1)

Vertex(17) = MakeVertex(-1, 1, -1, 0, 1, 0, 0, 0)
Vertex(18) = MakeVertex(1, 1, -1, 0, 1, 0, 1, 0)
Vertex(19) = MakeVertex(-1, 1, 1, 0, 1, 0, 0, 1)
Vertex(20) = MakeVertex(1, 1, 1, 0, 1, 0, 1, 1)
Vertex(21) = MakeVertex(-1, -1, -1, 0, -1, 0, 0, 0)
Vertex(22) = MakeVertex(1, -1, -1, 0, -1, 0, 1, 0)
Vertex(23) = MakeVertex(-1, -1, 1, 0, -1, 0, 0, 1)
Vertex(24) = MakeVertex(1, -1, 1, 0, -1, 0, 1, 1)

' Copy the vertices into the vertex buffer
D3DVertexBuffer8SetData VertexBuffer, 0, 24 * Len(Vertex(1)), 0, Vertex(1)

' Make a list which tells the order in which to render these vertices
MakeIndices 1, 2, 3, 3, 2, 4, 5, 6, 7, 7, 6, 8, 9, 10, 11, 11, 10, 12, 13, 14, 15, 15, 14, 16, 17, 18, 19, 19, 18, 20, 21, 22, 23, 23, 22, 24

' Copy the indices into the index buffer
D3DIndexBuffer8SetData IndexBuffer, 0, 36 * Len(Index(1)), 0, Index(1)

' Set the vertex format
D3Ddevice.SetVertexShader D3DFVF_VERTEX

' Set the vertex and index buffers as current ones to render from
D3Ddevice.SetStreamSource 0, VertexBuffer, Len(Vertex(1))
D3Ddevice.SetIndices IndexBuffer, -1

' Initializtion is complete!
Init = True
Exit Function

InitFailed: ' the initialization function has failed
Init = False

End Function






' MAKEVECTOR

' This function creates vectors

Function MakeVector(x As Single, y As Single, z As Single) As D3DVECTOR

With MakeVector
.x = x
.y = y
.z = z
End With
End Function






' MAKEVERTEX

' This function creates vertices

Function MakeVertex(x As Single, y As Single, z As Single, nx As Single, ny As Single, nz As Single, tu As Single, tv As Single) As D3DVERTEX

With MakeVertex
.x = x
.y = y
.z = z
.nx = nx
.ny = ny
.nz = nz
.tu = tu
.tv = tv
End With
End Function



' MAKEINDICES

' This function creates a list of indice ' s

Function MakeIndices(ParamArray Indices()) As Integer()

Dim i As Integer
For i = LBound(Indices) To UBound(Indices)
Index(i + 1) = Indices(i)
Next
End Function






' MAINLOOP

' This sub animates the scene by moving ' the positions of the
' cubes and the camera position, then re ' nders the cubes. It
' checks to see if the escape key has be ' en pressed and loops
' if it has not.

Sub MainLoop()

' the mathematical constant pi
Const PI = 3.1415
' the speed of animation
Const SPEED = 0.01
' matrices for animation and cameras
Dim matTranslation As D3DMATRIX, matRotation As D3DMATRIX, matScaling As D3DMATRIX, matView As D3DMATRIX, matProjection As D3DMATRIX, matTransform As D3DMATRIX
' camera position
Dim CameraPos As D3DVECTOR
On Error Resume Next
Do
' let Windows messages be executed
DoEvents
' get keyboard and mouse data
Keyboard.GetDeviceStateKeyboard KeyboardState
Mouse.GetDeviceStateMouse MouseState
' if escape was pressed, exit program
If KeyboardState.Key(DIK_ESCAPE) Then Exit Do
' move camera with mouse
CameraPos.y = CameraPos.y + MouseState.lY / 10
CameraPos.z = -2
' set camera position, using mouse data
D3DXMatrixLookAtLH matView, MakeVector(CameraPos.x, CameraPos.y, CameraPos.z), MakeVector(0, 0, 0), MakeVector(0, 1, 0)
D3Ddevice.SetTransform D3DTS_VIEW, matView
D3DXMatrixPerspectiveFovLH matProjection, PI / 3, 0.75, 0.1, 10000
D3Ddevice.SetTransform D3DTS_PROJECTION, matProjection
' move the rotation angle
Rotation = Rotation + SPEED
If Rotation > 2 * PI Then
Rotation = Rotation - 2 * PI
' once per rotation, play a sound
Sound.Play DSBPLAY_DEFAULT
End If
' clear the rendering device backbuffer and z-buffer
D3Ddevice.Clear 0, ByVal 0, D3DCLEAR_TARGET Or D3DCLEAR_ZBUFFER, vbWhite, 1#, 0
' start rendering
D3Ddevice.BeginScene
' create rotation matrix
D3DXMatrixRotationYawPitchRoll matTransform, Rotation * 2, Rotation, Rotation
' set the world matrix to normal
D3Ddevice.SetTransform D3DTS_WORLD, matTransform
' draw the medium cube
DrawCube
' create movement, rotation and scale matrices
D3DXMatrixTranslation matTranslation, 0, 0, 4
D3DXMatrixRotationYawPitchRoll matRotation, 0, Rotation * 2, Rotation * 4
D3DXMatrixScaling matScaling, 0.5, 0.5, 0.5
' combine them
D3DXMatrixMultiply matTransform, matRotation, matTranslation
D3DXMatrixMultiply matTransform, matTransform, matScaling
' transform the world matrix
D3Ddevice.MultiplyTransform D3DTS_WORLD, matTransform
' draw the small cube
DrawCube
' create movement, rotation and scale matrices
D3DXMatrixTranslation matTranslation, -3, -3, -3
D3DXMatrixRotationYawPitchRoll matRotation, Rotation * 8, 0, Rotation * 6
D3DXMatrixScaling matScaling, 0.5, 0.5, 0.5
' combine them
D3DXMatrixMultiply matTransform, matTranslation, matRotation
D3DXMatrixMultiply matTransform, matTransform, matScaling
' transform the world matrix
D3Ddevice.MultiplyTransform D3DTS_WORLD, matTransform
' draw the small cube
DrawCube
' end rendering
D3Ddevice.EndScene
' present the contents of the backbuffer by flipping it to the screen
D3Ddevice.Present ByVal 0, ByVal 0, 0, ByVal 0
Loop
End Sub






' DRAWCUBE

' Draws the cube

Sub DrawCube()

On Error Resume Next
' draw 12 triangles, in a cube shape, onto the backbuffer of the rendering device
D3Ddevice.DrawIndexedPrimitive D3DPT_TRIANGLELIST, 0, 36, 0, 12
End Sub





' CLEANUP

' This unloads all the DirectX objects - ' we destroy objects we
' have created, an disassociate our poin ' ters from objects
' create by DirectX, so then DirectX can ' destroy them. Failing
' to call this sub can cause memory to b ' e lost.

Sub CleanUp()


On Error Resume Next

Set Keyboard = Nothing
Set Mouse = Nothing
Set DI = Nothing

Set Sound = Nothing
Set DS = Nothing

Set Texture = Nothing
Set D3Ddevice = Nothing
Set D3DX = Nothing
Set D3D = Nothing

End Sub