End
End If
On Error Resume Next
'首先尝试建立硬件3维设备对象(HAL)
Set Direct3DDevice = d3d.CreateDevice("IID_IDirect3DHALDevice", BackBuffer)
'如果Direct3DDevice为Nothing说明显示卡不支持硬件Direct3D设备
'尝试建立RGB3维设备。
If Direct3DDevice Is Nothing Then
Set Direct3DDevice = d3d.CreateDevice("IID_IDirect3DRGBDevice", BackBuffer)
End If
'定义视角区域
Dim VPDesc As D3DVIEWPORT7
VPDesc.lWidth = g_rcDest.Right - g_rcDest.Left
VPDesc.lHeight = g_rcDest.Bottom - g_rcDest.Top
VPDesc.minz = 0#
VPDesc.maxz = 1#
'设置Direct3DDevice对象的视角
Direct3DDevice.SetViewport VPDesc
'保存对视角的设置
With ViewPortRect(0)
.X1 = 0: .Y1 = 0
.X2 = VPDesc.lWidth
.Y2 = VPDesc.lHeight
End With
iViewSize = 4
End Sub
'InitDeviceObjects函数建立三维物体
Private Sub InitDeviceObjects()
'建立立方体的顶点数据
CreateCube g_vCube
'通过位图文件建立三个纹理表面
Set TextureSurface1 = CreateTextureSurface("t1.bmp")
Set TextureSurface2 = CreateTextureSurface("t2.bmp")
Set TextureSurface3 = CreateTextureSurface("t3.bmp")
'使用泛光源以及白色的普通材质
Dim mtrl As D3DMATERIAL7
'定义材质对光源的的反射属性，你可以尝试改变它们的值看一下材质
'的反射效果
mtrl.diffuse.r = 1#: mtrl.diffuse.g = 0#: mtrl.diffuse.b = 1#
mtrl.Ambient.r = 1#: mtrl.Ambient.g = 1#: mtrl.Ambient.b = 1#: mtrl.Ambient.a = 1
mtrl.emissive.r = 1#: mtrl.emissive.g = 0#: mtrl.emissive.b = 1#
mtrl.emissive.r = 1#: mtrl.specular.g = 1#: mtrl.specular.b = 1#
'将材质的清晰度设置为10
mtrl.power = 10
Direct3DDevice.SetMaterial mtrl
'设置Direct3DDevice的光源为泛光源，你可以尝试对SetRenderState函数的
'第一个参数使用不同的值，看看光源的效果。
Direct3DDevice.SetRenderState D3DRENDERSTATE_AMBIENT, _
g_dx.CreateColorRGBA(1#, 1#, 0#, 1#)
Dim matProj As D3DMATRIX
g_dx.IdentityMatrix matProj
Call g_dx.ProjectionMatrix(matProj, 1, 1000, pi / 4#)
Direct3DDevice.SetTransform D3DTRANSFORMSTATE_PROJECTION, matProj
End Sub
'CreateCube函数建立立方体的顶点数据
Private Sub CreateCube(vertices() As D3DVERTEX)
'一个立方体有6个面，每面有是一个正方形，有4个顶点，下面共定义了
'这6个面的24个顶点
g_dx.CreateD3DVertex -1, 1, -1, 0, 0, -1, 0, 0, vertices(0)
g_dx.CreateD3DVertex 1, 1, -1, 0, 0, -1, 1, 0, vertices(1)
g_dx.CreateD3DVertex -1, -1, -1, 0, 0, -1, 0, 1, vertices(2)
g_dx.CreateD3DVertex 1, -1, -1, 0, 0, -1, 1, 1, vertices(3)
g_dx.CreateD3DVertex -1, 1, 1, 0, 0, 1, 1, 0, vertices(4)
g_dx.CreateD3DVertex -1, -1, 1, 0, 0, 1, 1, 1, vertices(5)
g_dx.CreateD3DVertex 1, 1, 1, 0, 0, 1, 0, 0, vertices(6)
g_dx.CreateD3DVertex 1, -1, 1, 0, 0, 1, 0, 1, vertices(7)
g_dx.CreateD3DVertex -1, 1, 1, 0, 1, 0, 0, 0, vertices(8)
g_dx.CreateD3DVertex 1, 1, 1, 0, 1, 0, 1, 0, vertices(9)
g_dx.CreateD3DVertex -1, 1, -1, 0, 1, 0, 0, 1, vertices(10)
g_dx.CreateD3DVertex 1, 1, -1, 0, 1, 0, 1, 1, vertices(11)
g_dx.CreateD3DVertex -1, -1, 1, 0, -1, 0, 0, 0, vertices(12)
g_dx.CreateD3DVertex -1, -1, -1, 0, -1, 0, 0, 1, vertices(13)
g_dx.CreateD3DVertex 1, -1, 1, 0, -1, 0, 1, 0, vertices(14)
g_dx.CreateD3DVertex 1, -1, -1, 0, -1, 0, 1, 1, vertices(15)
g_dx.CreateD3DVertex 1, 1, -1, 1, 0, 0, 0, 0, vertices(16)
g_dx.CreateD3DVertex 1, 1, 1, 1, 0, 0, 1, 0, vertices(17)
g_dx.CreateD3DVertex 1, -1, -1, 1, 0, 0, 0, 1, vertices(18)
g_dx.CreateD3DVertex 1, -1, 1, 1, 0, 0, 1, 1, vertices(19)
g_dx.CreateD3DVertex -1, 1, -1, -1, 0, 0, 1, 0, vertices(20)
g_dx.CreateD3DVertex -1, -1, -1, -1, 0, 0, 1, 1, vertices(21)
g_dx.CreateD3DVertex -1, 1, 1, -1, 0, 0, 0, 0, vertices(22)
g_dx.CreateD3DVertex -1, -1, 1, -1, 0, 0, 0, 1, vertices(23)
End Sub
Public Function CreateTextureSurface(sFile As String) As DirectDrawSurface7
Dim ddsTexture As DirectDrawSurface7
Dim i As Long
Dim bIsFound As Boolean
Dim ddsd As DDSURFACEDESC2
'定义纹理平面的属性
ddsd.lFlags = DDSD_CAPS Or DDSD_HEIGHT Or DDSD_WIDTH Or DDSD_PIXELFORMAT _
Or DDSD_TEXTURESTAGE
Dim TextureEnum As Direct3DEnumPixelFormats
'获得当前Direct3DDevice支持的所有纹理类型
Set TextureEnum = Direct3DDevice.GetTextureFormatsEnum()
'便历所有纹理类型，找到符合需要的类型
For i = 1 To TextureEnum.GetCount()
bIsFound = True
Call TextureEnum.GetItem(i, ddsd.ddpfPixelFormat)
With ddsd.ddpfPixelFormat
'跳过不常使用的格式
If .lFlags And (DDPF_LUMINANCE Or DDPF_BUMPLUMINANCE Or DDPF_BUMPDUDV) Then
bIsFound = False
End If
'跳过FourCC格式
If .lFourCC <> 0 Then bIsFound = False
文章整理：西部数码--专业提供域名注册、虚拟主机服务
http://www.west263.com
以上信息与文章正文是不可分割的一部分,如果您要转载本文章,请保留以上信息，谢谢!
