Imports Microsoft.Xna.Framework.Content
Imports Microsoft.Xna.Framework.Graphics
Imports Microsoft.Xna.Framework
Imports System.Windows.Graphics
Partial Public Class MainPage
Inherits UserControl
Public Sub New()
InitializeComponent()
End Sub
Dim contentManager As ContentManager
Dim spriteBatch As SpriteBatch
Dim cameraPositon As Vector3 = New Vector3(0,16.0F,11.0F)
Dim cameraTarget As Vector3 = New Vector3(0,3.0F,-2.0F)
Dim cameraUpVector As Vector3 = New Vector3(0,19.0F,11.0F)
Dim mouseCaptured As Boolean
Dim originalPosition As Vector2?
Dim model As Model
Dim graphicsDevice As GraphicsDevice
Dim speed As Double = 0.1F
Private Sub myDrawingSurface_MouseLeftButtonDown(sender As System.Object,e As System.Windows.Input.MouseButtonEventArgs)
Focus()
Dim location As System.Windows.Point = e.GetPosition(myDrawingSurface)
Dim rectangle As Rect = New Rect(0,myDrawingSurface.RenderSize.Width,myDrawingSurface.RenderSize.Height)
If (rectangle.Contains(location)) Then
mouseCaptured = True
HandleMouseDown(New Vector2(CDbl(location.X),CDbl(location.Y)))
End If
End Sub
Public Sub HandleMouseDown(ByVal position As Vector2)
originalPosition = position
End Sub
Public Sub HandleMouseMove(ByVal position As Vector2)
If (Not originalPosition.HasValue) Then
originalPosition = position
End If
Dim diff As Vector2 = (originalPosition.Value - position)
If diff = Vector2.Zero Then
Return
End If
If diff.X = 0 Then
Dim side As Integer = 0
If position.X = 0 Then
side = -1
ElseIf position.X = myDrawingSurface.RenderSize.Width - 1 Then
side = 1
End If
diff.X -= 20 * side
End If
diff *= 0.004F
cameraTarget -= New Vector3(diff.X,cameraTarget.Y,cameraTarget.Z)
originalPosition = position
End Sub
Private Sub myDrawingSurface_MouseLeftButtonUp(sender As System.Object,e As System.Windows.Input.MouseButtonEventArgs)
If (mouseCaptured) Then
mouseCaptured = False
End If
End Sub
Private Sub myDrawingSurface_MouseMove(sender As System.Object,e As System.Windows.Input.MouseEventArgs)
If (mouseCaptured) Then
Dim location As System.Windows.Point = e.GetPosition(myDrawingSurface)
HandleMouseMove(New Vector2(CDbl(location.X),CDbl(location.Y)))
End If
End Sub
Private Sub myDrawingSurface_KeyUp(sender As System.Object,e As System.Windows.Input.KeyEventArgs)
End Sub
Private Sub myDrawingSurface_Loaded(sender As System.Object,e As System.Windows.RoutedEventArgs)
graphicsDevice = GraphicsDeviceManager.Current.GraphicsDevice
Dim contentManager As ContentManager = New ContentManager(Nothing,"Content/Searching3DContent")
spriteBatch = New SpriteBatch(graphicsDevice)
model = contentManager.Load(Of Model)("Searching")
End Sub
Private Sub myDrawingSurface_Draw(sender As System.Object,e As System.Windows.Controls.DrawEventArgs)
graphicsDevice = GraphicsDeviceManager.Current.GraphicsDevice
graphicsDevice.Clear(Color.Black)
spriteBatch = New SpriteBatch(graphicsDevice)
spriteBatch.Begin(0,BlendState.AlphaBlend)
spriteBatch.End()
graphicsDevice.DepthStencilState = DepthStencilState.Default
DrawModels(graphicsDevice,model)
e.InvalidateSurface()
End Sub
Public Sub DrawModels(ByVal graphicsDevice As GraphicsDevice,ByVal models As Model)
Dim transforms = New Matrix(models.Bones.Count) {}
models.CopyAbsoluteBoneTransformsTo(transforms)
For Each mesh As ModelMesh In models.Meshes
For Each effect As BasicEffect In mesh.Effects
effect.World = transforms(mesh.ParentBone.Index)
effect.View = Matrix.CreateLookAt(cameraPositon,cameraTarget,cameraUpVector)
effect.Projection = Matrix.CreatePerspectiveFieldOfView(MathHelper.Pi / 3.3F,graphicsDevice.Viewport.AspectRatio,1,1000)
effect.EnableDefaultLighting()
effect.SpecularColor = Vector3.One
Next
mesh.Draw()
Next
End Sub
Private Sub myDrawingSurface_KeyDown(sender As System.Object,e As System.Windows.Input.KeyEventArgs)
Dim direction As Vector3 = Vector3.Zero
Select Case e.Key
Case Key.W
direction = New Vector3(0,-speed)
Case Key.S
direction = New Vector3(0,speed)
Case Key.A
direction = New Vector3(-speed,0)
Case Key.D
direction = New Vector3(speed,0)
End Select
If direction <> Vector3.Zero Then
cameraTarget = New Vector3(direction.X + cameraTarget.X,direction.Y + cameraTarget.Y,direction.Z + cameraTarget.Z)
cameraPositon = New Vector3(direction.X + cameraPositon.X,direction.Y + cameraPositon.Y,direction.Z + cameraPositon.Z)
End If
End Sub
Private Sub myDrawingSurface_MouseWheel(sender As System.Object,e As System.Windows.Input.MouseWheelEventArgs)
Dim direction As Vector3 = Vector3.Zero
If e.Delta > 0 Then
direction = New Vector3(0,-speed,-speed)
Else
direction = New Vector3(0,speed,speed)
End If
If direction <> Vector3.Zero Then
cameraTarget = New Vector3(direction.X + cameraTarget.X,direction.Z + cameraTarget.Z)
End If
End Sub
End Class
''' <summary>
''' 获取模型资源
''' </summary>
''' <param name="obj"></param>
''' <param name="args"></param>
''' <remarks></remarks>
Private Sub wb_OpenReadCompleted(obj As Object,args As OpenReadCompletedEventArgs)
NewSearchingContent = New SearchingContentManager(Nothing,"Content/")
graphicsDevice = GraphicsDeviceManager.Current.GraphicsDevice
'添加Source资源
Dim modelsDic As New Dictionary(Of String,Dictionary(Of String,Byte()))
For Each modelNames As String In Source.Split(",")
Dim modelsDicName As String = modelNames.Split("|")(0)
For Each modelName As String In modelNames.Split("|")
Dim modelDic As Dictionary(Of String,Byte()) = GetModelDictionary(args.Result,modelName)
If Not modelsDic.ContainsKey(modelsDicName) Then modelsDic.Add(modelsDicName,modelDic)
Next
'读取完成加载模型
NewSearchingContent.newModelByte = modelsDic
listModel.Add(searchingContent.Load(Of Model)(modelsDicName))
Next
End Sub
''' <summary>
''' 获取模型资源字典
''' </summary>
''' <param name="result">资源包流文件</param>
''' <param name="modelName">模型名称</param>
''' <returns></returns>
''' <remarks></remarks>
Private Function GetModelDictionary(ByVal result As Stream,ByVal modelName As String) As Dictionary(Of String,Byte())
Dim xap As StreamResourceInfo = New Windows.Resources.StreamResourceInfo(result,Nothing)
Dim modelStream As Stream = Application.GetResourceStream(xap,New Uri(modelName,UriKind.Relative)).Stream
'Stream转换为bytes()
Dim modelBytes() As Byte = New Byte(modelStream.Length) {}
modelStream.Read(modelBytes,modelBytes.Length)
modelStream.Seek(0,SeekOrigin.Begin)
Dim dic As New Dictionary(Of String,Byte())
dic.Add(modelName,modelBytes)
Return dic
End Function
Dim wb As New WebClient()
Private Sub ModelEx_Loaded(ByVal sender As Object,ByVal e As System.Windows.RoutedEventArgs) Handles Me.Loaded
wb.OpenReadAsync(New Uri("SilverlightModel.xap",UriKind.Relative))
AddHandler wb.OpenReadCompleted,AddressOf wb_OpenReadCompleted
End Sub
原文链接:https://www.f2er.com/vb/259163.html