MainForm.vb
' Copyright 2010 ESRI ' ' All rights reserved under the copyright laws of the United States ' and applicable international laws, treaties, and conventions. ' ' You may freely redistribute and use this sample code, with or ' without modification, provided you include the original copyright ' notice and use restrictions. ' ' See the use restrictions. ' Imports System Imports System.Collections.Generic Imports System.ComponentModel Imports System.Data Imports System.Drawing Imports System.Text Imports System.Windows.Forms Imports System.Diagnostics Imports ESRI.ArcGIS.Controls Imports ESRI.ArcGIS.GlobeCore Imports ESRI.ArcGIS.esriSystem Imports ESRI.ArcGIS.SystemUI Imports ESRI.ArcGIS Imports ESRI.ArcGIS.Carto Imports ESRI.ArcGIS.DataSourcesGDB Imports ESRI.ArcGIS.Geometry Imports ESRI.ArcGIS.Geodatabase Imports ESRI.ArcGIS.DefenseSolutions Namespace GlobeControlApp Public NotInheritable Partial Class MainForm Inherits Form #Region "private class members" Private m_globeControl As IGlobeControl = Nothing Private m_globeViewUtil As IGlobeViewUtil = Nothing #End Region #Region "class constructor" Public Sub New() RuntimeManager.Bind(ProductCode.Engine) InitializeComponent() End Sub #End Region #Region "Main Menu event handlers" Private Sub menuOpenDoc_Click(ByVal sender As Object, ByVal e As EventArgs) Handles menuOpenDoc.Click 'execute Open Document command Dim command As ICommand = New ControlsGlobeOpenDocCommandClass() command.OnCreate(m_globeControl.[Object]) command.OnClick() End Sub Private Sub menuExitApp_Click(ByVal sender As Object, ByVal e As EventArgs) Handles menuExitApp.Click 'exit the application Application.[Exit]() End Sub #End Region ''' <summary> ''' Mouse move event handler ''' </summary> ''' <param name="sender"></param> ''' <param name="e"></param> Private Sub axGlobeControl1_OnMouseMove(ByVal sender As Object, ByVal e As IGlobeControlEvents_OnMouseMoveEvent) Handles axGlobeControl1.OnMouseMove Dim dLon As Double, dLat As Double, dAlt As Double 'convert the window coordinate into geographic coordinates m_globeViewUtil.WindowToGeographic(m_globeControl.GlobeDisplay, m_globeControl.GlobeDisplay.ActiveViewer, e.x, e.y, True, dLon, _ dLat, dAlt) 'report the mouse geographic coordinate onto the statusbar statusBarXY.Text = String.Format("{0} {1} {2}", dLon.ToString("###.###"), dLat.ToString("###.###"), dAlt.ToString("###.###")) End Sub ' Called when a globe document is opened using the file open button or menu. Private Sub axGlobeControl1_OnGlobeReplaced(ByVal sender As System.Object, ByVal e As IGlobeControlEvents_OnGlobeReplacedEvent) Handles axGlobeControl1.OnGlobeReplaced ' Load the MOLE Unit Feature Class Dim globe As IGlobe = Me.axGlobeControl1.Globe m_MoleFC = LoadMoleFeatureClassInGlobe(globe) End Sub ' Checks if a valid MOLE feature class has been loaded onto the globe. Private Function MoleFcIsValid() As Boolean If m_MoleFC Is Nothing Then MessageBox.Show("Please open an ArcGlobe (.3dd) document" & Environment.NewLine & "before pressing this button.", _ "MOLE Globe", MessageBoxButtons.OK, MessageBoxIcon.Information) Return False End If Return True End Function Private Sub MainForm_FormClosing(ByVal sender As Object, ByVal e As FormClosingEventArgs) Handles MyBase.FormClosing End Sub ' The following code was added to a default(wizard generated) ' Globe Control Application in order to obtain a MOLE Layer in 3D, ' insert a feature, and refresh the layer. Private m_MoleFC As IFeatureClass = Nothing Private m_addedUnitCt As Integer = 0 ''' <summary> ''' Form Load event handler ''' </summary> ''' <param name="sender"></param> ''' <param name="e"></param> Private Sub MainForm_Load(ByVal sender As Object, ByVal e As EventArgs) Handles MyBase.Load m_globeControl = TryCast(axGlobeControl1.[Object], IGlobeControl) 'cast the GlobeViewUtil from the GlobeCamera m_globeViewUtil = TryCast(m_globeControl.GlobeCamera, IGlobeViewUtil) End Sub ''' <summary> ''' Add a "Add Unit" button and use this as its event handler ''' </summary> Private Sub butTest_Click(ByVal sender As Object, ByVal e As EventArgs) Handles butTest.Click If (Not MoleFcIsValid()) Then Return End If AddUnitToFC(m_MoleFC) Dim globeDisplay As IGlobeDisplay = axGlobeControl1.GlobeDisplay RefreshMoleLayers(globeDisplay) End Sub ''' <summary> ''' Add a "Move All Units" button and use this as its event handler ''' </summary> Private Sub butTest2_Click(ByVal sender As Object, ByVal e As EventArgs) Handles butTest2.Click If (Not MoleFcIsValid()) Then Return End If MoveAllUnits(m_MoleFC) Dim globeDisplay As IGlobeDisplay = axGlobeControl1.GlobeDisplay RefreshMoleLayers(globeDisplay) End Sub ''' <summary> ''' Refreshes all MOLE Layers in a GlobeControl ''' </summary> Private Sub RefreshMoleLayers(ByVal globeDisplay As IGlobeDisplay) Dim map As IBasicMap = TryCast(globeDisplay.Globe, IBasicMap) ' find the mole Force Element layers and refresh them Dim enumLayer As IEnumLayer = map.Layers(Nothing, True) enumLayer.Reset() Dim layer As ILayer = enumLayer.Next() While layer IsNot Nothing If TypeOf layer Is IForceElementLayer Then ' Code required to get a MOLE Layer to rebuild & refresh in Globe Dim MoleLayer As ICachedGraphicLayer = TryCast(layer, ICachedGraphicLayer) MoleLayer.Refresh() globeDisplay.SuspendTileFetch() Dim layer3DSettings As I3DSettings = TryCast(MoleLayer, I3DSettings) If layer3DSettings IsNot Nothing And layer3DSettings.DisplayOption <> mole3DDisplayEnum.mole3DDisplayExtrude Then ' use optimized refresh Dim display As ESRI.ArcGIS.Display.IDisplay = TryCast(globeDisplay, ESRI.ArcGIS.Display.IDisplay) layer.Draw(esriDrawPhase.esriDPGeography, display, Nothing) Else ' Use normal GlobeDisplay refresh (Does not perform as well) TryCast(globeDisplay, IGlobeDisplayLayers).RefreshLayer(layer) End If globeDisplay.ResumeTileFetch() End If layer = enumLayer.Next() End While End Sub ''' <summary> ''' Adds a Unit to a feature class with the MOLE data model ''' </summary> Private Sub AddUnitToFC(ByVal featureClass As IFeatureClass) Try ' Random Number Generation (so each new unit shows up at a different point) Const maxRandom As Double = 5 Dim randomGenerator As New System.Random() Dim dRandom As Double = randomGenerator.NextDouble() * maxRandom ' create the new feature Dim newFeature As IFeature = featureClass.CreateFeature() ' get an insert cursor Dim insertCursor As IFeatureCursor = featureClass.Insert(False) If newFeature IsNot Nothing Then ' create a random point for the unit's location Dim point As IPoint = New PointClass() point.PutCoords(-117 + dRandom, 35 + dRandom / 2) point.Z = 100 Dim za As IZAware = TryCast(point, IZAware) za.ZAware = True ' set the feature's shape newFeature.Shape = TryCast(point, IGeometry) ' set feature fields (SIC, name) Dim symbolIdCode As String = "S" Dim affilCode As Char = "F"c ' Set a different affiliation for each new unit added. Dim affil As Integer = m_addedUnitCt Mod 4 Select Case affil Case 0 affilCode = "F"c Case 1 affilCode = "H"c Case 2 affilCode = "N"c Case 3 affilCode = "U"c Case Else End Select ' Set the symbol ID code symbolIdCode = symbolIdCode & affilCode & "GPUCI-----USG" newFeature.Value(newFeature.Table.FindField("Symbol_ID")) = symbolIdCode ' Increment the unit counter used for the unit label. m_addedUnitCt += 1 ' Set the label for the unit graphic. Dim testName As String = "Test Insert Unit " & m_addedUnitCt newFeature.Value(newFeature.Table.FindField("Name")) = testName insertCursor.InsertFeature(TryCast(newFeature, IFeatureBuffer)) End If ' make sure changes are committed before we exit insertCursor.Flush() Catch e As Exception Trace.WriteLine(e.Message) End Try End Sub ''' <summary> ''' Moves all point geometries in a Feature Class ''' </summary> Private Sub MoveAllUnits(ByVal featureClass As IFeatureClass) Try ' get all features Dim updateCursor As IFeatureCursor = featureClass.Update(Nothing, False) Dim updateFeature As IFeature = updateCursor.NextFeature() While updateFeature IsNot Nothing Dim geometry As IGeometry = updateFeature.Shape Dim point As IPoint = TryCast(geometry, IPoint) ' make sure not an empty/corrupt geometry If (geometry IsNot Nothing) AndAlso (point IsNot Nothing) AndAlso (Not geometry.IsEmpty) Then point.X += 0.2 updateFeature.Shape = geometry updateCursor.UpdateFeature(updateFeature) End If updateFeature = updateCursor.NextFeature() End While Catch e As Exception Trace.WriteLine(e.Message) End Try End Sub ''' <summary> ''' Loads a MOLE Layer in Globe ''' </summary> ''' <remarks> ''' This is very similar to the 2D usage with additional code to ''' set the I3DSettings properties for the layer ''' </remarks> Private Function LoadMoleFeatureClassInGlobe(ByVal globe As IGlobe) As IFeatureClass Dim dbPath As String = MoleMDB Dim fc As IFeatureClass = LoadAccessFeatureClass(dbPath, "FriendlyForces") Debug.WriteLine("Attempting to Add MOLE Layer") Dim pFeatureLayer As IGeoFeatureLayer = TryCast(New FeatureLayer(), IGeoFeatureLayer) pFeatureLayer.FeatureClass = fc 'Create a MOLE layer and attach the feature layer to it Dim pLayer As ICachedGraphicFeatureLayer = TryCast(New ForceElementLayer(), ICachedGraphicFeatureLayer) pLayer.FeatureLayer = pFeatureLayer 'Set the size for symbols in the layer Dim pForceElementLayer As IForceElementLayer = TryCast(pLayer, IForceElementLayer) pForceElementLayer.Size = 0.2 ' Set 3D Settings Dim p3DSettings As I3DSettings = TryCast(pForceElementLayer, I3DSettings) p3DSettings.DisplayOption = mole3DDisplayEnum.mole3DDisplayBoth ' or .mole3DDisplayExtrude; // or mole3DDisplayDrape p3DSettings.EnableCallouts = True p3DSettings.DefaultElevationMeters = 10000 Dim layer As ILayer = TryCast(pLayer, ILayer) layer.Name = "MOLE 3D Unit Layer" globe.AddLayerType(layer, ESRI.ArcGIS.GlobeCore.esriGlobeLayerType.esriGlobeLayerTypeDraped, True) System.Diagnostics.Debug.WriteLine("Layer Added") Return fc End Function ''' <summary> ''' Opens a Feature Class from an Access PGDB ''' </summary> Private Function LoadAccessFeatureClass(ByVal dbPath As String, ByVal featureClassName As String) As IFeatureClass ' open the access database Dim pWSF As IWorkspaceFactory = New AccessWorkspaceFactoryClass() Dim pWS As IWorkspace = pWSF.OpenFromFile(dbPath, 0) ' make sure the database was opened If pWS Is Nothing Then MessageBox.Show("Could not locate and/or open database at: """ + dbPath + """", "Error!") Return Nothing End If Dim pFWS As IFeatureWorkspace = TryCast(pWS, IFeatureWorkspace) Dim pFC As IFeatureClass SyncLock pFWS ' lock to prevent multi-process access ' open the feature class pFC = pFWS.OpenFeatureClass(featureClassName) End SyncLock ' make sure the feature class was opened If pFC Is Nothing Then MessageBox.Show("Could not open feature class: " + featureClassName + ".", "Error!") Return Nothing End If Return pFC End Function ''' <summary> ''' Path to ArcGIS Install ''' </summary> Private Function GetSdkDataPath() As String 'get the ArcGIS path from the registry Dim key As Microsoft.Win32.RegistryKey = Microsoft.Win32.Registry.LocalMachine.OpenSubKey("SOFTWARE\ESRI\ArcGIS_SXS_SDK") Dim path As String = Convert.ToString(key.GetValue("InstallDir")) 'set the of the logo Dim str As String = System.IO.Path.Combine(path, "Samples\data\") If (Not System.IO.Directory.Exists(str)) Then MessageBox.Show("Path :" & str & " does not exist!") Return String.Empty End If Return str End Function ''' <summary> ''' Path to MOLE globe Access PGDB data file ''' </summary> Public ReadOnly Property MoleMDB() As String Get If m_DataPath Is Nothing Then m_DataPath = GetSdkDataPath() + "MilitaryOverlayEditor\mole_globe.mdb" End If Return m_DataPath End Get End Property Private Shared m_DataPath As String = Nothing End Class End Namespace