FORM1
Private Sub Form_Load()
IntHoritzontal = 800
IntVertical = 600
InicializarVideo IntHoritzontal, IntVertical
Inicizentorno 'call to Inicizentorno
Do While DoEvents
'infinite loop calling Accion function
Accion
Loop
End Sub
MODULE
Option Explicit
'last chapter definitions
Public IntHoritzontal As Integer
Public IntVertical As Integer
Public Direct As New DirectX7
Public Ddraw As DirectDraw4
Public Ddrm As Direct3DRM3
Public DDclipper As DirectDrawClipper
Public DDsurface As DirectDrawSurface4
Public DDsurfacesec As DirectDrawSurface4
Public DDSDsurface As DDSURFACEDESC2
Public DDSCAP As DDSCAPS2
Public RMDevice As Direct3DRMDevice3
Public RMViewport As Direct3DRMViewport2
Public Textureim As Direct3DRMLoadTextureCallback3
Public MeshCargar As Direct3DRMMeshBuilder3
Public FramePrincipal As Direct3DRMFrame3
Public Camara As Direct3DRMFrame3
Public FrameCargar As Direct3DRMFrame3
Public LuzAmbiental As Direct3DRMLight
Public Luz1 As Direct3DRMLight
'New definitions
Public DirecInput As DirectInput 'to
activate Direct X
Public DirectTeclat As DirectInputDevice 'To
activate Device
Public EstatTeclat As DIKEYBOARDSTATE '
to select Keyboar
Public StrText As String 'To
write text
Public Bucle As Integer
'The INICIALIZARVIDEO commands are explainet in the first chapter tutorial
Public Function InicializarVideo(Horitzontal As Integer, Vertical As
Integer)
Set Ddraw = Direct.DirectDraw4Create("")
Form1.Show
Ddraw.SetCooperativeLevel Form1.hWnd, DDSCL_FULLSCREEN Or DDSCL_EXCLUSIVE
Ddraw.SetDisplayMode Horitzontal, Vertical, 16, 0, DDSDM_DEFAULT
DDSDsurface.lFlags = DDSD_CAPS Or DDSD_BACKBUFFERCOUNT
DDSDsurface.ddsCaps.lCaps = DDSCAPS_PRIMARYSURFACE Or DDSCAPS_3DDEVICE
Or DDSCAPS_COMPLEX Or DDSCAPS_FLIP
DDSDsurface.lBackBufferCount = 1
Set DDsurface = Ddraw.CreateSurface(DDSDsurface)
DDSCAP.lCaps = DDSCAPS_BACKBUFFER
Set DDsurfacesec = DDsurface.GetAttachedSurface(DDSCAP)
Set Ddrm = Direct.Direct3DRMCreate()
Set RMDevice = Ddrm.CreateDeviceFromSurface("IID_IDirect3DHALDevice",
Ddraw, DDsurfacesec, D3DRMDEVICE_DEFAULT)
RMDevice.SetBufferCount 2
RMDevice.SetQuality D3DRMLIGHT_ON Or D3DRMFILL_SOLID Or D3DRMSHADE_GOURAUD
Or D3DRMSHADE_MAX
RMDevice.SetTextureQuality D3DRMTEXTURE_MIPNEAREST
RMDevice.SetRenderMode D3DRMRENDERMODE_DEFAULT
End Function
Public Function Inicizentorno()
Set FramePrincipal = Ddrm.CreateFrame(Nothing) '
Set Camara = Ddrm.CreateFrame(FramePrincipal)
Set RMViewport = Ddrm.CreateViewport(RMDevice, Camara, 0, 0, IntHoritzontal,
IntVertical)
'
RMViewport.Clear D3DRMCLEAR_TARGET Or D3DRMCLEAR_ZBUFFER
RMViewport.SetBack 5000
'DirecInput
'KEYBOARD
Set DirecInput = Direct.DirectInputCreate
'create a direct input
Set DirectTeclat = DirecInput.CreateDevice("GUID_SysKeyboard")
'assing direct input to keyboard
DirectTeclat.SetCommonDataFormat DIFORMAT_KEYBOARD
'prepare keyboad data
DirectTeclat.SetCooperativeLevel Form1.hWnd,
DISCL_NONEXCLUSIVE Or DISCL_BACKGROUND 'select
working mode
CargarX "/torre.x" 'call to CargarX function
FrameCargar.SetPosition FramePrincipal, 0, 0, 0
'FrameCargar.SetRotation FramePrincipal, 0, 1,
0, 0.01 ' DELETE THIS LINE
DELETE THIS LINE DELETE
THIS LINE
Camara.SetPosition FramePrincipal, 0, 0, -300
luzdirecciona 0.8, 0.8, 0.8
LuzAmbiente 0.1, 0.1, 0.1
End Function
Public Function Accion()
RMViewport.Clear D3DRMCLEAR_TARGET Or D3DRMCLEAR_ZBUFFER
RMDevice.Update
RMViewport.Render FramePrincipal
Ddrm.Tick 1
KeyPresset 'Call
Keypresset function 'New parameters
DDsurface.Flip Nothing, DDFLIP_WAIT
End Function
Public Function CargarX(StrNombreX As String)
Set FrameCargar = Ddrm.CreateFrame(FramePrincipal)
Set MeshCargar = Ddrm.CreateMeshBuilder()
MeshCargar.LoadFromFile App.Path & StrNombreX, 0, D3DRMLOAD_ASYNCHRONOUS,
Textureim, Nothing
MeshCargar.SetPerspective D_TRUE
FrameCargar.AddVisual MeshCargar
End Function
Public Function LuzAmbiente(rojo As Single, verde As Single, Blue As
Single)
Set LuzAmbiental = Ddrm.CreateLightRGB(D3DRMLIGHT_AMBIENT, rojo, verde,
Blue)
FramePrincipal.AddLight LuzAmbiental
End Function
Public Function luzdirecciona(rojo As Single, verde As Single, azul
As Single)
Set Luz1 = Ddrm.CreateLightRGB(D3DRMLIGHT_POINT, rojo, verde, azul)
Luz1.SetUmbra 0.0001
Luz1.SetPenumbra 0.0001
Camara.AddLight Luz1
End Function
Public Function KeyPresset()
DirectTeclat.Acquire
'Get keyboard
DirectTeclat.GetDeviceStateKeyboard EstatTeclat
'Select the presset keys
If EstatTeclat.Key(1) <> 0 Then 'ESC
to end program
Discharge
End If
'Keys Movemente
,arrow keys and pageup, pagedown
If EstatTeclat.Key(200) <> 0 Then
Camara.AddTranslation D3DRMCOMBINE_BEFORE, 0,
0, 2
End If
If EstatTeclat.Key(208) <> 0 Then
Camara.AddTranslation D3DRMCOMBINE_BEFORE, 0,
0, -2
End If
If EstatTeclat.Key(205) <> 0 Then
Camara.AddRotation D3DRMCOMBINE_BEFORE, 0, 1,
0, 0.01
End If
If EstatTeclat.Key(203) <> 0 Then
Camara.AddRotation D3DRMCOMBINE_BEFORE, 0, 1,
0, -0.01
End If
If EstatTeclat.Key(201) <> 0 Then
Camara.AddRotation D3DRMCOMBINE_BEFORE, 1, 0,
0, -0.01
End If
If EstatTeclat.Key(209) <> 0 Then
Camara.AddRotation D3DRMCOMBINE_BEFORE, 1, 0,
0, 0.01
End If
'Write the presset key on screen
For Bucle = 0 To 255
If EstatTeclat.Key(Bucle) <> 0 Then
LettersWriter 100, 150, CStr(Bucle), 2500
End If
Next Bucle
End Function
Public Function LettersWriter(StrPosicioX As String,
StrPosicioY As String, StrText As String, SngColor As Single)
'Write something in the specified position
DDsurfacesec.SetForeColor SngColor
DDsurfacesec.DrawText StrPosicioX, StrPosicioY,
StrText, False
End Function
Public Function Discharge()
'discharge DirectX
DirectTeclat.Unacquire 'Returns
the keyboard control
Ddraw.RestoreAllSurfaces
Set DirecInput = Nothing
Set DirectTeclat = Nothing
Set FramePrincipal = Nothing
Set Camara = Nothing
Set DDclipper = Nothing
Set DDsurface = Nothing
Set DDsurfacesec = Nothing
Set RMDevice = Nothing
Set RMViewport = Nothing
Set Ddrm = Nothing
Set Ddraw = Nothing
Set Direct = Nothing
End
End Function
You can download a source code.
|