spieleprogrammierer.de - Forum und Wiki zur Spieleprogrammierung und Spieleentwicklung

Quellcode

Imports System
Imports System.Drawing
Imports System.Windows.Forms
Imports Microsoft.DirectX
Imports Microsoft.DirectX.Direct3D



Namespace Direct3DTest2
    Public Class MyGraphicsSample
        Inherits GraphicsSample 'Alles von Class GraphicsSample erben

        Public AnzahlObjekte As Integer = 2048
        Public vbObjekte As VertexBuffer
        Public ibObjekte As IndexBuffer
        Public vCameraPos As Vector3 = New Vector3(0, 0, 0)
        Public CameraWinkel As Single = 0

        Public Sub New()
        End Sub 'New

        Protected Overrides Sub FrameMove()
        End Sub 'FrameMove

        Public Sub RenderScene()
            Device.SetStreamSource(0, vbObjekte, 0)
            Device.Indices = ibObjekte
            Device.DrawIndexedPrimitives(PrimitiveType.TriangleList, 0, 0, AnzahlObjekte * 8, 0, AnzahlObjekte * 12)
        End Sub 'RenderScene

        Protected Overrides Sub Render()
            Device.Clear(ClearFlags.Target Or ClearFlags.ZBuffer, Drawing.Color.Blue.ToArgb, 1, 0)
            Device.BeginScene()
            RenderScene()
            Device.EndScene()
        End Sub 'Render

        Protected Overrides Sub InitializeDeviceObjects()
            Try
                Device.VertexFormat = VertexFormats.Position Or VertexFormats.Diffuse Or VertexFormats.Texture1

                Device.RenderState.Lighting = False
                Device.RenderState.CullMode = Cull.None
                Device.RenderState.DitherEnable = True

                Device.SamplerState(0).MinFilter = TextureFilter.Linear
                Device.SamplerState(0).MagFilter = TextureFilter.Linear
                Device.SamplerState(0).MipFilter = TextureFilter.Linear

                Dim tmpTextur As Texture
                tmpTextur = TextureLoader.FromFile(Device, "Texture.bmp", 256, 256, 1, 0, Format.Unknown, Pool.Managed, Filter.None, Filter.Linear, 0)
                Device.SetTexture(0, tmpTextur)

                vbObjekte = New VertexBuffer(GetType(CustomVertex.PositionColoredTextured), AnzahlObjekte * 8, Device, 0, CustomVertex.PositionColoredTextured.Format, Pool.Managed)
                ibObjekte = New IndexBuffer(GetType(Short), AnzahlObjekte * 36, Device, 0, Pool.Managed)

                Dim Verts() As CustomVertex.PositionColoredTextured
                Dim Indices() As Short

                Verts = DirectCast(vbObjekte.Lock(0, LockFlags.NoSystemLock), CustomVertex.PositionColoredTextured())
                Indices = DirectCast(ibObjekte.Lock(0, LockFlags.NoSystemLock), Short())

                Dim n, m As Integer
                Dim tmpPos As New Vector3
                Dim StartVertex, StartIndex As Integer
                For n = 0 To AnzahlObjekte - 1
                    tmpPos.X = 250 * Rnd() + 20
                    tmpPos.Y = 250 * Rnd() + 20
                    tmpPos.Z = 250 * Rnd() + 20

                    StartVertex = n * 8
                    StartIndex = n * 36

                    Verts(StartVertex + 0) = New CustomVertex.PositionColoredTextured(tmpPos.X + -1, tmpPos.Y + 1, tmpPos.Z + -1, 0, Rnd, Rnd)
                    Verts(StartVertex + 1) = New CustomVertex.PositionColoredTextured(tmpPos.X + -1, tmpPos.Y + 1, tmpPos.Z + -1, 0, Rnd, Rnd)
                    Verts(StartVertex + 2) = New CustomVertex.PositionColoredTextured(tmpPos.X + -1, tmpPos.Y + 1, tmpPos.Z + -1, 0, Rnd, Rnd)
                    Verts(StartVertex + 3) = New CustomVertex.PositionColoredTextured(tmpPos.X + -1, tmpPos.Y + 1, tmpPos.Z + -1, 0, Rnd, Rnd)
                    Verts(StartVertex + 4) = New CustomVertex.PositionColoredTextured(tmpPos.X + -1, tmpPos.Y + 1, tmpPos.Z + -1, 0, Rnd, Rnd)
                    Verts(StartVertex + 5) = New CustomVertex.PositionColoredTextured(tmpPos.X + -1, tmpPos.Y + 1, tmpPos.Z + -1, 0, Rnd, Rnd)
                    Verts(StartVertex + 6) = New CustomVertex.PositionColoredTextured(tmpPos.X + -1, tmpPos.Y + 1, tmpPos.Z + -1, 0, Rnd, Rnd)
                    Verts(StartVertex + 7) = New CustomVertex.PositionColoredTextured(tmpPos.X + -1, tmpPos.Y + 1, tmpPos.Z + -1, 0, Rnd, Rnd)

                    Indices(StartIndex + 0) = 0 : Indices(StartIndex + 1) = 3 : Indices(StartIndex + 2) = 7
                    Indices(StartIndex + 3) = 0 : Indices(StartIndex + 4) = 7 : Indices(StartIndex + 5) = 4
                    Indices(StartIndex + 6) = 2 : Indices(StartIndex + 7) = 5 : Indices(StartIndex + 8) = 1
                    Indices(StartIndex + 9) = 2 : Indices(StartIndex + 10) = 5 : Indices(StartIndex + 11) = 6
                    Indices(StartIndex + 12) = 1 : Indices(StartIndex + 13) = 0 : Indices(StartIndex + 14) = 4
                    Indices(StartIndex + 15) = 1 : Indices(StartIndex + 16) = 4 : Indices(StartIndex + 17) = 5
                    Indices(StartIndex + 18) = 3 : Indices(StartIndex + 19) = 2 : Indices(StartIndex + 20) = 6
                    Indices(StartIndex + 21) = 3 : Indices(StartIndex + 22) = 6 : Indices(StartIndex + 23) = 7
                    Indices(StartIndex + 24) = 0 : Indices(StartIndex + 25) = 1 : Indices(StartIndex + 26) = 2
                    Indices(StartIndex + 27) = 0 : Indices(StartIndex + 28) = 2 : Indices(StartIndex + 29) = 3
                    Indices(StartIndex + 30) = 6 : Indices(StartIndex + 31) = 5 : Indices(StartIndex + 32) = 4
                    Indices(StartIndex + 33) = 6 : Indices(StartIndex + 34) = 4 : Indices(StartIndex + 35) = 7

                Next n

                vbObjekte.Unlock()
                ibObjekte.Unlock()

                Dim Aspect As Single
                Aspect = Device.PresentationParameters.BackBufferWidth / Device.PresentationParameters.BackBufferHeight
                Device.Transform.Projection = Matrix.PerspectiveFovLH(CSng(Math.PI) / 4, Aspect, 0.1, 250)
                Device.Transform.View = Matrix.LookAtLH(New Vector3(0, 0, 0), New Vector3(0, 0, -100), New Vector3(0, 1, 0))
                Device.Transform.World = Matrix.Identity
            Catch
                Dim e As New MediaNotFoundException
                HandleSampleException(e, ApplicationMessage.ApplicationMustExit)
                Throw e
            End Try
        End Sub 'InitializeDeviceObjects

        Protected Overrides Sub RestoreDeviceObjects(ByVal sender As System.Object, ByVal e As System.EventArgs)
        End Sub 'RestoreDeviceObjects

        Shared Sub Main()
            Dim d3dApp As New MyGraphicsSample

            If d3dApp.CreateGraphicsSample() Then
                d3dApp.Run()
            End If
        End Sub 'Main
    End Class 'MyGraphicsSample
End Namespace 'Direct3DTest2