Keskustelu: Koodit: VB6: 3D Motor

Dim DX As New clsD3DKernel
Dim I As String
Private Sub Form_Click()
'sammuu
Sammutus
End Sub

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
'kameran liikkeet(x,y,z)
Dim CPos As D3DVECTOR
CPos = DX.Camera([Get Position])
With DX
Select Case KeyCode
    Case vbKeyLeft
        'left
        .CameraOrientation [Goto Left]

    Case vbKeyRight
        'right
        .CameraOrientation [Goto Right]
    Case vbKeyUp
        'Up
        .Camera [Set Position], CPos.X, CPos.y, CPos.Z + 2
    Case vbKeyDown
        'down
        .Camera [Set Position], CPos.X, CPos.y, CPos.Z - 2
    Case vbKeyEscape
        'Esc
        Sammutus
End Select
End With
End Sub

Private Sub Form_Load()
Show
I = App.Path & "\"
    '1024 = resoluutio width
    '768 =  resoluutio height
    '32 = värien määrä esim:(32)
    'vbWhite = PN teksti(tekstin väri)
    'vbBlack = Taustaväri (ilman tausta kuvaa)
DX.Kuva Me.hWnd, 1024, 768, 32, vbWhite, vbBlack, [Hardware Render]
'Lamppu "Valoa pimeään"
DX.Val
'Taustakuva jee!
DX.Tausta I & "Sky.bmp"

'Lattiat seinät ja muut
DX.Lattia 100, 100, 0, 0, 0, I & "floor.BMP", 7, 7
DX.Seinä W_Taka, 100, 25, 0, 0, 100, I & "wall.bmp", 7, 2
DX.Seinä W_Vasen, 100, 25, 0, 0, 0, I & "wall.bmp", 7, 2


'valo
DX.Valo 100, 10, 240, 1, 0.7, 0.7, 0.7
'laitetaan lehmä tai muita hemmoja esim: autoja
'DX.XFil I & "cow.x", 2, 20, 8, 20


'kamera(x 50 - y 10 - z 50)
DX.Camera [Set Position], 50, 10, 50

'käy tarkistamaassa fontit
DX.Fontti SetupFont()
'teksti yläkulmassa
DX.Teksti "Petrinm", 0, 0
'piilottaa hiiren pelin ajaksi
DX.Hiiri False
DX.Luk
End Sub

Private Sub Form_Unload(Cancel As Integer)
'sammutetaan
Sammutus
End Sub

Public Sub Sammutus()
'hiiri näkyviin
DX.Hiiri True
DX.StopRender
DX.Terminate
Set DX = Nothing
End
End Sub

'tekstin asetukset "P.N"
Public Function SetupFont() As StdFont
Dim Fa As New StdFont
Fa.Bold = True
Fa.Italic = True
Fa.Name = "Times New Roman"
Fa.Size = 30
Set SetupFont = Fa
Set Fa = Nothing
End Function

Private DX_Main As New DirectX7
Private DD_Main As DirectDraw4
Private D3D_Main As Direct3DRM3
Private DS_Front As DirectDrawSurface4
Private DS_Back As DirectDrawSurface4
Private SD_Front As DDSURFACEDESC2
Private DD_Back As DDSCAPS2
Private D3D_Device As Direct3DRMDevice3
Private D3D_ViewPort As Direct3DRMViewport2
Private FR_Root As Direct3DRMFrame3
Private FR_Camera As Direct3DRMFrame3
Private LT_Ambient As Direct3DRMLight
Private FR_Building As Direct3DRMFrame3
Private ESC As Boolean
Private Init As Boolean
Private mHWND As Long
Private zText As String
Private zX As Long
Private zY As Long
Private Const Sin5 = 8.715574E-02!
Private Const Cos5 = 0.9961947!

Public Enum enumAccelerationType
    [Hardware Render]
    [Software Render]
End Enum

Public Enum enumCameraAction
    [Get Position]
    [Set Position]
End Enum

Public Enum enumWallFace
    W_Etu
    W_Taka
    W_Vasen
    W_Oikea
End Enum

Public Enum enumOrientationType
    [Goto Left]
    [Goto Right]
End Enum

Private Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long

Public Function Lattia(X_Size As Single, Y_Size As Single, X As Single, y As Single, Z As Single, Texture As String, X_Tile As Integer, Y_Tile As Integer) As Boolean
On Error GoTo ER:
If Init = False Then Exit Function
  Dim FloorFace As Direct3DRMFace2
  Dim FloorTexture As Direct3DRMTexture3
  Dim MS_Floor As Direct3DRMMeshBuilder3

  Set MS_Floor = D3D_Main.CreateMeshBuilder()
  Set FloorTexture = D3D_Main.LoadTexture(Texture)

  Set FloorFace = D3D_Main.CreateFace

  FloorFace.AddVertex X, y, Z: FloorFace.AddVertex X, y, Z + Y_Size: FloorFace.AddVertex X + X_Size, y, Z + Y_Size: FloorFace.AddVertex X + X_Size, y, Z

  MS_Floor.AddFace FloorFace

  MS_Floor.SetTextureCoordinates 0, 0, Y_Tile
  MS_Floor.SetTextureCoordinates 1, 0, 0
  MS_Floor.SetTextureCoordinates 2, X_Tile, 0
  MS_Floor.SetTextureCoordinates 3, X_Tile, Y_Tile

  MS_Floor.SetPerspective 1

  Set FloorFace = MS_Floor.GetFace(0)
  FloorFace.SetTexture FloorTexture

  FR_Building.AddVisual MS_Floor
Lattia = True
Exit Function
ER:
Lattia = False
End Function

Public Function Valo(X As Single, y As Single, Z As Single, LType As CONST_D3DRMLIGHTTYPE, vred As Single, vgreen As Single, vblue As Single) As Boolean
On Error GoTo ER:
If Init = False Then Exit Function
  Dim FR_NewLight As Direct3DRMFrame3
  Dim LT_Light As Direct3DRMLight

  Set FR_NewLight = D3D_Main.CreateFrame(FR_Root)

  Set LT_Light = D3D_Main.CreateLightRGB(LType, vred, vgreen, vblue)

  FR_NewLight.SetPosition Nothing, X, y, Z
  FR_NewLight.AddLight LT_Light
Valo = True
Exit Function
ER:
Valo = False
End Function

Public Function XFil(XFile As String, MeshScale As Single, X As Single, y As Single, Z As Single) As Boolean
On Error GoTo ER:
If Init = False Then Exit Function
  Dim FR_Mesh As Direct3DRMFrame3
  Dim MS_Mesh As Direct3DRMMeshBuilder3

  Set FR_Mesh = D3D_Main.CreateFrame(FR_Root)
  Set MS_Mesh = D3D_Main.CreateMeshBuilder()
  'jos virhe löytyy tästä x tiedostoa ei ole
  MS_Mesh.LoadFromFile XFile, 0, 0, Nothing, Nothing
  MS_Mesh.ScaleMesh MeshScale, MeshScale, MeshScale

  FR_Mesh.SetPosition Nothing, X, y, Z
  FR_Mesh.AddVisual MS_Mesh
XFil = True
Exit Function
ER:
XFil = False
End Function


Public Function Katto(X_Size As Single, Y_Size As Single, X As Single, y As Single, Z As Single, Texture As String, X_Tile As Integer, Y_Tile As Integer) As Boolean
On Error GoTo ER:
If Init = False Then Exit Function
  Dim RoofFace As Direct3DRMFace2
  Dim RoofTexture As Direct3DRMTexture3
  Dim MS_Roof As Direct3DRMMeshBuilder3
  Set MS_Roof = D3D_Main.CreateMeshBuilder()
  Set RoofTexture = D3D_Main.LoadTexture(Texture)
  Set RoofFace = D3D_Main.CreateFace
  RoofFace.AddVertex X + X_Size, y, Z: RoofFace.AddVertex X + X_Size, y, Z + Y_Size: RoofFace.AddVertex X, y, Z + Y_Size: RoofFace.AddVertex X, y, Z
  MS_Roof.AddFace RoofFace

  MS_Roof.SetTextureCoordinates 0, 0, Y_Tile
  MS_Roof.SetTextureCoordinates 1, 0, 0
  MS_Roof.SetTextureCoordinates 2, X_Tile, 0
  MS_Roof.SetTextureCoordinates 3, X_Tile, Y_Tile

  MS_Roof.SetPerspective 1
  Set RoofFace = MS_Roof.GetFace(0)
  RoofFace.SetTexture RoofTexture
  FR_Building.AddVisual MS_Roof
Katto = True
Exit Function
ER:
Katto = False
End Function

Public Function Seinä(WallType As enumWallFace, X_Size As Single, Y_Size As Single, X As Single, y As Single, Z As Single, Texture As String, X_Tile As Integer, Y_Tile As Integer) As Boolean
  On Error GoTo ER:
  If Init = False Then Exit Function
  Dim WallFace As Direct3DRMFace2
  Dim WallTexture As Direct3DRMTexture3
  Dim MS_Wall As Direct3DRMMeshBuilder3
  Set MS_Wall = D3D_Main.CreateMeshBuilder()
  Set WallTexture = D3D_Main.LoadTexture(Texture)
  Set WallFace = D3D_Main.CreateFace
  If WallType = W_Etu Then
    WallFace.AddVertex X, y, Z: WallFace.AddVertex X, y + Y_Size, Z: WallFace.AddVertex X + X_Size, y + Y_Size, Z: WallFace.AddVertex X + X_Size, y, Z
    WallFace.AddVertex X + X_Size, y, Z: WallFace.AddVertex X + X_Size, y + Y_Size, Z: WallFace.AddVertex X, y + Y_Size, Z: WallFace.AddVertex X, y, Z
  ElseIf WallType = W_Taka Then
    WallFace.AddVertex X + X_Size, y, Z: WallFace.AddVertex X + X_Size, y + Y_Size, Z: WallFace.AddVertex X, y + Y_Size, Z: WallFace.AddVertex X, y, Z
    WallFace.AddVertex X, y, Z: WallFace.AddVertex X, y + Y_Size, Z: WallFace.AddVertex X + X_Size, y + Y_Size, Z: WallFace.AddVertex X + X_Size, y, Z
  ElseIf WallType = W_Vasen Then
    WallFace.AddVertex X, y, Z: WallFace.AddVertex X, y + Y_Size, Z: WallFace.AddVertex X, y + Y_Size, Z + X_Size: WallFace.AddVertex X, y, Z + X_Size
    WallFace.AddVertex X, y, Z + X_Size: WallFace.AddVertex X, y + Y_Size, Z + X_Size: WallFace.AddVertex X, y + Y_Size, Z: WallFace.AddVertex X, y, Z
  ElseIf WallType = W_Oikea Then
    WallFace.AddVertex X, y, Z + X_Size: WallFace.AddVertex X, y + Y_Size, Z + X_Size: WallFace.AddVertex X, y + Y_Size, Z: WallFace.AddVertex X, y, Z
    WallFace.AddVertex X, y, Z: WallFace.AddVertex X, y + Y_Size, Z: WallFace.AddVertex X, y + Y_Size, Z + X_Size: WallFace.AddVertex X, y, Z + X_Size
  Else
    Exit Function
  End If

  MS_Wall.AddFace WallFace

  MS_Wall.SetTextureCoordinates 0, 0, Y_Tile
  MS_Wall.SetTextureCoordinates 1, 0, 0
  MS_Wall.SetTextureCoordinates 2, X_Tile, 0
  MS_Wall.SetTextureCoordinates 3, X_Tile, Y_Tile
  MS_Wall.SetTextureCoordinates 4, X_Tile, Y_Tile
  MS_Wall.SetTextureCoordinates 5, X_Tile, 0
  MS_Wall.SetTextureCoordinates 6, 0, 0
  MS_Wall.SetTextureCoordinates 7, 0, Y_Tile

  MS_Wall.SetPerspective 1

  Set WallFace = MS_Wall.GetFace(0)
  WallFace.SetTexture WallTexture

  FR_Building.AddVisual MS_Wall
Seinä = True
Exit Function
ER:
Seinä = False
End Function


Public Function Kuva(lHWND As Long, lScreenWidth As Long, lScreenHeight As Long, lScreenDepth As Long, lForeColor As Long, lBackColor As Long, RenderType As enumAccelerationType, Optional lDrawDistance As Long = -1) As Boolean
On Error GoTo InitError
mHWND = lHWND
Set DD_Main = DX_Main.DirectDraw4Create("")

DD_Main.SetCooperativeLevel mHWND, DDSCL_FULLSCREEN Or DDSCL_EXCLUSIVE
DD_Main.SetDisplayMode lScreenWidth, lScreenHeight, lScreenDepth, 0, DDSDM_DEFAULT
SD_Front.lFlags = DDSD_CAPS Or DDSD_BACKBUFFERCOUNT
SD_Front.ddsCaps.lCaps = DDSCAPS_PRIMARYSURFACE Or DDSCAPS_3DDEVICE Or DDSCAPS_COMPLEX Or DDSCAPS_FLIP
SD_Front.lBackBufferCount = 1
Set DS_Front = DD_Main.CreateSurface(SD_Front)
DD_Back.lCaps = DDSCAPS_BACKBUFFER
Set DS_Back = DS_Front.GetAttachedSurface(DD_Back)
DS_Back.SetForeColor lForeColor
Set D3D_Main = DX_Main.Direct3DRMCreate()
    If RenderType = [Hardware Render] Then
        Set D3D_Device = D3D_Main.CreateDeviceFromSurface("IID_IDirect3DHALDevice", DD_Main, DS_Back, D3DRMDEVICE_DEFAULT)
    ElseIf RenderType = [Software Render] Then
        Set D3D_Device = D3D_Main.CreateDeviceFromSurface("IID_IDirect3DRGBDevice", DD_Main, DS_Back, D3DRMDEVICE_DEFAULT)
    End If
D3D_Device.SetBufferCount 2
D3D_Device.SetQuality D3DRMRENDER_GOURAUD Or D3DRMLIGHT_ON Or D3DRMSHADE_GOURAUD
D3D_Device.SetTextureQuality D3DRMTEXTURE_LINEAR Or D3DRMTEXTURE_NEAREST
D3D_Device.SetRenderMode D3DRMRENDERMODE_BLENDEDTRANSPARENCY
Set FR_Root = D3D_Main.CreateFrame(Nothing)
Set FR_Camera = D3D_Main.CreateFrame(FR_Root)
Set FR_Building = D3D_Main.CreateFrame(FR_Root)
FR_Root.SetSceneBackground lBackColor
Set D3D_ViewPort = D3D_Main.CreateViewport(D3D_Device, FR_Camera, 0, 0, lScreenWidth, lScreenHeight)
    If lDrawDistance = -1 Then
    D3D_ViewPort.SetBack lScreenWidth
    Else
    D3D_ViewPort.SetBack lDrawDistance
    End If
Camera [Set Position], 0, 0, 0
zText = ""
zX = 0
zY = 0
Init = True
Kuva = True
Exit Function
InitError:
Init = False
Kuva = False
End Function

Public Function Terminate()
On Error Resume Next
If Init = False Then Exit Function
DD_Main.RestoreDisplayMode
DD_Main.SetCooperativeLevel mHWND, DDSCL_NORMAL
Set DX_Main = Nothing
Set DD_Main = Nothing
Set D3D_Main = Nothing

Set DS_Front = Nothing
Set DS_Back = Nothing

Set D3D_Device = Nothing
Set D3D_ViewPort = Nothing

Set FR_Root = Nothing
Set FR_Camera = Nothing
Set LT_Ambient = Nothing
zText = ""
zX = 0
zY = 0
Init = False
End Function


Public Function Val(Optional sRed As Single = 0.45, Optional sGreen As Single = 0.45, Optional sBlue As Single = 0.45)
If Init = False Then Exit Function
Set LT_Ambient = D3D_Main.CreateLightRGB(D3DRMLIGHT_AMBIENT, sRed, sGreen, sBlue)
'FR_Root '.Valo
FR_Root.AddLight LT_Ambient
End Function

Public Function Tausta(FileName As String) As Boolean
On Error GoTo ER:
If Init = False Then Exit Function
FR_Root.SetSceneBackgroundImage MakeTexture(FileName)
Tausta = True
Exit Function
ER:
Tausta = False
End Function
Private Function MakeTexture(FileName As String) As Direct3DRMTexture3
On Error Resume Next
Set MakeTexture = D3D_Main.LoadTexture(FileName)
End Function


Public Function Camera(ActionToDo As enumCameraAction, Optional aX As Single, Optional aY As Single, Optional aZ As Single) As D3DVECTOR
On Error Resume Next
If Init = False Then Exit Function
If ActionToDo = [Get Position] Then
    FR_Camera.GetPosition FR_Camera, Camera
ElseIf ActionToDo = [Set Position] Then
    FR_Camera.SetPosition FR_Camera, aX, aY, aZ
End If
End Function

Public Function Luk()
On Error GoTo ER:
Do Until ESC = True
DoEvents
    D3D_ViewPort.Clear D3DRMCLEAR_TARGET Or D3DRMCLEAR_ZBUFFER
    D3D_Device.Update
    D3D_ViewPort.Render FR_Root
    DS_Back.DrawText zX, zY, zText, False
    DS_Front.Flip Nothing, DDFLIP_WAIT
DoEvents
Loop
ER:
ESC = False
End Function

Public Function StopRender()
If Init = False Then Exit Function
ESC = True
End Function

Public Function CameraOrientation(Orien As enumOrientationType) As Boolean
If Init = False Then Exit Function
On Error GoTo ER:
If Orien = [Goto Left] Then
    FR_Camera.SetOrientation FR_Camera, -Sin5, 0, Cos5, 0, 1, 0
ElseIf Orien = [Goto Right] Then
    FR_Camera.SetOrientation FR_Camera, Sin5, 0, Cos5, 0, 1, 0
End If
CameraOrientation = True
Exit Function
ER:
CameraOrientation = False
End Function

Public Function Teksti(sText As String, aX As Long, aY As Long) As Boolean
On Error GoTo ER:
If Init = False Then Exit Function
zText = sText
zX = aX
zY = aY
Teksti = True
Exit Function
ER:
Teksti = False
End Function

Public Function Fontti(newFont As StdFont) As Boolean
On Error GoTo ER:
If Init = False Then Exit Function
DS_Back.SetFont newFont
Fontti = True
Exit Function
ER:
Fontti = False
End Function

Public Function Hiiri(bShow As Boolean)
ShowCursor bShow
End Function