VERSION 5.00
Begin VB.Form frmGlobe
BackColor = &H00000000&
Caption = "Direct3D Globe Sample"
ClientHeight = 3195
ClientLeft = 60
ClientTop = 345
ClientWidth = 4680
LinkTopic = "Form1"
ScaleHeight = 3195
ScaleWidth = 4680
StartUpPosition = 3 'Windows Default
Begin VB.Timer Timer1
Enabled = 0 'False
Interval = 1
Left = 120
Top = 120
End
End
Attribute VB_Name = "frmGlobe"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
' Based on the DirectX SDK retained mode tutorial...
' Define TEXTURE as True to use texture mapping
' Define TEXTURE as False to use material
#Const TEXTURE = True
'Private Declare Function DirectDrawCreateClipper Lib "ddraw" (ByVal dwFlags As Long, ByRef lplpDDCLipper As IUnknown, ByVal lng2 As Long) As Long
Const pi = 3.14159265358979
Dim objD3DRM As Direct3DRM
Dim Scene As Direct3DRMFrame
Dim Camera As Direct3DRMFrame
Dim objDDClipper As DirectDrawClipper
Dim dev As Direct3DRMDevice
Dim view As Direct3DRMViewPort
Dim LightFrame As Direct3DRMFrame
Dim WorldFrame As Direct3DRMFrame
Dim Light As Direct3DRMLight
Dim Globe As Direct3DRMMeshBuilder
Dim objMaterial As Direct3DRMMaterial
Dim Distance As Long
' Create a sphere (probably to improve)
Sub CreateSphere(objMeshBuilder As Direct3DRMMeshBuilder)
Dim aVertices(1 To 1000) As D3DVECTOR
Dim aNormals(0) As D3DVECTOR
Dim aFaces(1 To 10000) As Long
Dim intVertices As Long
Const stepA = 10
Const stepB = 10
Dim axeZ As D3DVECTOR
Dim origine As D3DVECTOR
With origine
.x = 0
.y = 1
.z = 0
End With
axeZ.x = 0
axeZ.y = 0
axeZ.z = 1
Dim AxeY As D3DVECTOR
AxeY.x = 0
AxeY.y = 1
AxeY.z = 0
'aFaces(0) = 180 / stepA
intVertices = 1
Dim i As Integer
Dim j As Integer
Dim tmp As D3DVECTOR
For i = stepA To 180 - stepA Step stepA
For j = 0 To 360 - stepB Step stepB
D3DRMVectorRotate tmp, origine, axeZ, i * pi / 180
D3DRMVectorRotate aVertices(intVertices), tmp, AxeY, j * pi / 180
intVertices = intVertices + 1
Next
Next
intVertices = intVertices - 1
Dim Index As Integer
Index = 1
For i = stepA To 180 - 2 * stepA Step stepA
Dim FirstIndex As Long
FirstIndex = Index
For j = 0 To 360 - stepB Step stepB
aFaces(Index) = 4
aFaces(Index + 1) = (Index 5) + 1
aFaces(Index + 2) = (Index 5)
aFaces(Index + 3) = ((Index 5) + (360 stepB))
aFaces(Index + 4) = (Index 5) + 1 + (360 stepB)
If j = 360 - stepB Then
aFaces(Index + 1) = FirstIndex 5 '+ 1
aFaces(Index + 4) = FirstIndex 5 + (360 stepB)
End If
Index = Index + 5
Next
Next
'Index = 1
aFaces(Index) = (360 / stepB) - 1
Index = Index + 1
For i = 1 To (360 / stepB) - 1
aFaces(Index) = i
Index = Index + 1
Next
aFaces(Index) = 360 / stepB
Index = Index + 1
For i = 0 To (360 / stepB) - 1
aFaces(Index) = intVertices - i - 1
Index = Index + 1
Next
aFaces(Index) = 0
objMeshBuilder.AddFaces intVertices, aVertices(1), 0, aNormals(0), aFaces(1), Nothing
End Sub
Private Sub Form_KeyPress(KeyAscii As Integer)
Select Case Chr$(KeyAscii)
Case "+"
Distance = Distance + 1
Case "-"
Distance = Distance - 1
End Select
On Error Resume Next
WorldFrame.SetPosition Scene, 0, 0, Distance
End Sub
Private Sub Form_Load()
Distance = 15
Direct3DRMCreate objD3DRM
' Create the scene
objD3DRM.CreateFrame Nothing, Scene
' Create the camera
objD3DRM.CreateFrame Scene, Camera
Camera.SetPosition Scene, 0, 0, 0
DirectDrawCreateClipper 0&, objDDClipper, Nothing
objDDClipper.SetHWnd 0, Me.hWnd
objD3DRM.CreateDeviceFromClipper objDDClipper, 0&, 320, 200, dev
objD3DRM.CreateViewport dev, Camera, 0, 0, 320, 200, view
view.SetBack 5000
dev.SetQuality D3DRMLIGHT_ON Or D3DRMFILL_SOLID Or D3DRMSHADE_GOURAUD
' Create the light frame
objD3DRM.CreateFrame Scene, LightFrame
objD3DRM.CreateFrame Scene, WorldFrame
objD3DRM.CreateLightRGB D3DRMLIGHT_DIRECTIONAL, 0.9, 0.9, 0.9, Light
LightFrame.AddLight Light
Dim light2 As Direct3DRMLight
objD3DRM.CreateLightRGB D3DRMLIGHT_AMBIENT, 0.1, 0.1, 0.1, light2
Scene.AddLight light2
LightFrame.SetPosition Scene, 2, 0, 22
Camera.SetPosition Scene, 0, 0, 0
Camera.SetOrientation Scene, 0, 0, 1, 0, 1, 0
WorldFrame.SetPosition Scene, 0, 0, 15
WorldFrame.SetOrientation Scene, 0, 0, 1, 0, 1, 0
WorldFrame.SetRotation Scene, 1, 1, 1, 0.17 '0.05
objD3DRM.CreateMeshBuilder Globe
CreateSphere Globe
Globe.[Scale] 1, 1, 1
Globe.SetColorRGB 1, 1, 1
Globe.GenerateNormals
#If TEXTURE Then
Dim box As D3DRMBOX
Dim lpWrap As Direct3DRMWrap
Globe.GetBox box
Dim maxy As Single
Dim miny As Single
Dim height As Single
maxy = box.Max.y
miny = box.Min.y
height = maxy - miny
objD3DRM.CreateWrap D3DRMWRAP_CYLINDER, Nothing, _
0, 0, 0, 0, 1, 0, 0, 0, 1, 0, miny / height, 1, -1 / height, lpWrap
lpWrap.Apply Globe
Dim objTex As Direct3DRMTexture
objD3DRM.LoadTexture App.Path & "\Globe.bmp", objTex
Globe.SetTexture objTex
#Else
Globe.SetColorRGB 0.1, 0.1, 1
objD3DRM.CreateMaterial 5, objMaterial
With objMaterial
.SetEmissive 0.3, 0.3, 0.3
.SetSpecular 1, 1, 1
End With
Globe.SetMaterial objMaterial
#End If
WorldFrame.AddVisual Globe
Set LightFrame = Nothing
Set Globe = Nothing
Set Light = Nothing
Me!Timer1.Enabled = True
End Sub
Private Sub Form_Unload(Cancel As Integer)
Me!Timer1.Enabled = False
Set WorldFrame = Nothing
Set Scene = Nothing
Set Camera = Nothing
Set view = Nothing
Set dev = Nothing
Set objD3DRM = Nothing
Set objDDClipper = Nothing
End Sub
Private Sub Timer1_Timer()
On Error Resume Next
Scene.Move 1
view.Clear
view.Render Scene
dev.Update
End Sub
