'将后台绘图平面的尺寸保存到g_rcSrc中
With g_rcSrc
.Left = 0: .Top = 0
.Bottom = g_ddsd.lHeight
.Right = g_ddsd.lWidth
End With
Dim pcClipper As DirectDrawClipper
Set pcClipper = g_dd.CreateClipper(0)
pcClipper.SetHWnd Me.hWnd
MainBuffer.SetClipper pcClipper
End Sub
'InitD3D函数初始化Direct3D对象,包括3D设备、光源、视角以及材质
Sub InitD3D()
Dim d3d As Direct3D7
Dim ddsd As DDSURFACEDESC2
'从DirectDraw对象中获得Direct3D对象
Set d3d = g_dd.GetDirect3D
'获得DirectDraw对象的显示颜色深度,如果小于16位色,则程序出错退出
g_dd.GetDisplayMode ddsd
If ddsd.ddpfPixelFormat.lRGBBitCount <= 8 Then
MsgBox "本程序不支持颜色位数小于16bit的显示模式,程序将退出"
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
'保存对视角的设置
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")
Const NUM_CUBE_VERTICES As Integer = 4 * 6
Dim g_vCube(NUM_CUBE_VERTICES) As D3DVERTEX
'定义三个材质表面
Dim TextureSurface1 As DirectDrawSurface7
Dim TextureSurface2 As DirectDrawSurface7
Dim TextureSurface3 As DirectDrawSurface7
Dim g_dx As New DirectX7
Dim g_dd As DirectDraw7
Dim g_ddsd As DDSURFACEDESC2
Dim MainBuffer As DirectDrawSurface7
Dim BackBuffer As DirectDrawSurface7
Dim Direct3DDevice As Direct3DDevice7
Dim g_rcDest As RECT, g_rcSrc As RECT
Dim ViewPortRect(0) As D3DRECT
Dim bIsRunning As Boolean
Dim bRoAn As Boolean
Dim CNT As Single
Dim iViewSize As Integer
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
'根据不同的击键值来决定角度的变化
Select Case KeyCode
Case vbKeyUp
CNT = CNT + 6
bRoAn = True
Case vbKeyDown
CNT = CNT - 6
bRoAn = True
Case vbKeyLeft
CNT = CNT + 6
bRoAn = False
Case vbKeyRight
CNT = CNT - 6
bRoAn = False
Case vbKeySubtract
If iViewSize < 12 Then
iViewSize = iViewSize + 1
End If
Case vbKeyAdd
If iViewSize > 4 Then
iViewSize = iViewSize - 1
End If
End Select
End Sub
Private Sub Form_Load()
Dim j As Long
InitDDraw
InitD3D
InitDeviceObjects
Me.Show
bIsRunning = True
Do While bIsRunning = True
RenderScene
FrameMove (CNT / 360), bRoAn
g_dx.GetWindowRect Me.hWnd, g_rcDest
'将后台绘图平面的内容复制到前台
j = MainBuffer.Blt(g_rcDest, BackBuffer, g_rcSrc, DDBLT_WAIT)
If j <> DD_OK Then
MsgBox "无法将后台绘图平面的内容拷贝到前台,错误代码:" & Hex(j)
End
End If
DoEvents
Loop
End Sub
Private Sub FrameMove(stepVal As Single, bType As Boolean)
Dim matView As D3DMATRIX
Dim matTemp As D3DMATRIX
g_dx.IdentityMatrix matWorld
If bType Then
g_dx.RotateXMatrix matWorld, stepVal
Else
g_dx.RotateYMatrix matWorld, stepVal
End If
Direct3DDevice.SetTransform D3DTRANSFORMSTATE_WORLD, matWorld
End Sub
'RenderScene函数执行场景重绘和渲染
Private Sub RenderScene()
Dim i As Integer