Sphere Multipatch

Created:1/4/2001
Description:

Multipatches are a geometry type which can be useful in a 3D model environment. By adding small detailed sections of geometry to an IMultiPatch object, you can build features which represent complex geometry types such as surfaces, or simpler geometries such as spheres, cylinders, pyramids, and cubes.

This example demonstrates how to build spherical geometry.


How to use:
  1. Copy all of the code in this tip into a VBA module of ArcScene.
  2. Call the 'Sphere' procedure from a calling routine to create the IMultiPatch. The calling routine can then add the IMultiPatch shape to a feature class and load it into ArcScene.
  3. Or simply run the 'AddSphere' procedure, which offers an example of how this can be done. It uses the support procedures 'CreateShapeFile', 'OpenShapeFile', 'CreateBasicFields', 'AddShapeToFeatureClass', and 'AddFCToScene', which are included here.
Public Function Sphere( _
    minLon As Double, _
    maxLon As Double, _
    minLat As Double, _
    maxLat As Double, _
    origin As esriCore.IPoint, _
    radius As Double, _
    Optional bSmooth As Boolean = False, _
    Optional bFlipS As Boolean = False, _
    Optional bFlipT As Boolean = False) As IMultiPatch
    
    On Error GoTo EH
    
    Dim sampLon As Double
    'number of longitude values to base geometry resolution on
    sampLon = 36
    
    Dim xStep As Double
    Dim yStep As Double
    'derive step values:
    xStep = (maxLon - minLon) / sampLon
    yStep = (maxLat - minLat) / (sampLon / 2)
    
    Dim lonRange As Double
    lonRange = maxLon - minLon
    
    Dim latRange As Double
    latRange = maxLat - minLat
    
    Dim pMultiPatch As IMultiPatch
    Set pMultiPatch = New MultiPatch
    
    Dim pGCol As IGeometryCollection
    Set pGCol = pMultiPatch
    
    Dim pGeom As IGeometry2
    
    Dim pt As esriCore.IPoint
    
    Dim pStrip As IPointCollection
    
    Dim pVector As IVector3D
    Set pVector = New Vector3D
    
    Dim pGE As IEncode3DProperties
    Set pGE = New GeometryEnvironment
    
    Dim lon As Double
    For lon = minLon To (maxLon - xStep) Step xStep
        Set pStrip = New TriangleStrip
        Dim lat As Double
        For lat = minLat To maxLat Step yStep
            Dim azi As Double
            Dim inc As Double
            azi = DegreesToRadians(lon)
            inc = DegreesToRadians(lat)
            pVector.PolarSet -azi, inc, radius
            Set pt = New esriCore.Point
            pt.X = origin.X + pVector.XComponent
            pt.Y = origin.Y + pVector.YComponent
            pt.Z = origin.Z + pVector.ZComponent
            Dim s As Double
            s = (lon - minLon) / lonRange
            If (bFlipS) Then
              s = 1 + (s * -1)
            End If
            ' Due to floating point precision issues make sure
            ' texture coordinate in safe range.
            If (s <= 0) Then
              s = 0.001
            ElseIf (s >= 1) Then
              s = 0.999
            End If
            
            Dim t As Double
            t = (maxLat - lat) / latRange
            If (bFlipT) Then
              t = 1 + (t * -1)
            End If
            If (t <= 0) Then
              t = 0.001
            ElseIf (t >= 1) Then
              t = 0.999
            End If
            
            ' pack the s/t into same measure used for vector normal
            ' and assign the measure to the point
            Dim m As Double
            m = 0
            pGE.PackTexture2D s, t, m
            If (bSmooth) Then
                pVector.Normalize
                pGE.PackNormal pVector, m
            End If
            pt.m = m
            pStrip.AddPoint pt
            If ((lat <> -90) And (lat <> 90)) Then
                azi = DegreesToRadians(lon + xStep)
                inc = DegreesToRadians(lat)
                pVector.PolarSet -azi, inc, radius
                Set pt = New esriCore.Point
                pt.X = origin.X + pVector.XComponent
                pt.Y = origin.Y + pVector.YComponent
                pt.Z = origin.Z + pVector.ZComponent
                s = (lon + xStep - minLon) / lonRange
                If (bFlipS) Then
                    s = 1 + (s * -1)
                End If
                If (s <= 0) Then
                    s = 0.001
                ElseIf (s >= 1) Then
                    s = 0.999
                End If
                
                t = (maxLat - lat) / latRange
                If (bFlipT) Then
                    t = 1 + (t * -1)
                End If
                If (t <= 0) Then
                    t = 0.001
                ElseIf (t >= 1) Then
                    t = 0.999
                End If
                
                m = 0
                pGE.PackTexture2D s, t, m
                If (bSmooth) Then
                    pVector.Normalize
                    pGE.PackNormal pVector, m
                End If
                pt.m = m
                pStrip.AddPoint pt
            End If
        Next lat
        Set pGeom = pStrip
        pGCol.AddGeometry pGeom
    Next lon
    
    Dim pMAware As IMAware
    Set pMAware = pMultiPatch
    pMAware.MAware = True
    
    Set Sphere = pMultiPatch
    Exit Function
EH:
    Set Sphere = Nothing
End Function

Public Function DegreesToRadians(dDeg As Double) As Double
    Dim PI As Double
    PI = 4 * Atn(1#)
    
    Dim RAD As Double
    RAD = PI / 180#
    
    DegreesToRadians = dDeg * RAD
End Function    


'=======================================================================================
'=======================================================================================
'example usage:
Public Sub AddSphere()

	'a smooth sphere:'point used by sphere:
    Dim pPtOrigin As esriCore.IPoint
    Set pPtOrigin = New Point: pPtOrigin.X = 0: pPtOrigin.Y = 0: pPtOrigin.Z = 0
    
    Dim pMP1 As esriCore.IMultiPatch
    Set pMP1 = Sphere(0, 360, -90, 90, pPtOrigin, 5, True)
    If pMP1 Is Nothing Then
        MsgBox "The MultiPatch was not created."
        Exit Sub
    Else
        Dim pClone As IClone
        Dim pSxDoc As ISxDocument
        Set pSxDoc = Application.Document
        Set pClone = pSxDoc.Scene.SpatialReference
        
        Dim pSR As ISpatialReference
        Set pSR = New UnknownCoordinateSystem

        Dim pFCls1 As esriCore.IFeatureClass
        'create a new shapefile:

	Set pFCls1 = CreateShapefile("c:\temp\", "aSphere.shp", esriGeometryMultiPatch, True, True, pSR)
        'add the multipatch to the shapefile:
        AddShapeToFeatureClass pMP1, pFCls1
        'add the feature class to the scene:
        AddFCToScene pFCls1, "aSphere"
    
    End If
    
End Sub


Public Function CreateShapefile(sDir As String, sName As String, shapeType As esriGeometryType, _
  hasM As Boolean, hasZ As Boolean, pSR As ISpatialReference) As IFeatureClass
  
  Set CreateShapefile = Nothing
  
  Dim shapeWorkspaceFactory As IWorkspaceFactory
  Set shapeWorkspaceFactory = New ShapefileWorkspaceFactory
  
  Dim connectionProperties As IPropertySet
  Set connectionProperties = New PropertySet
  connectionProperties.SetProperty "DATABASE", sDir
  
  Dim shapeWorkspace As IFeatureWorkspace
  Set shapeWorkspace = shapeWorkspaceFactory.Open(connectionProperties, 0)
  If (Not shapeWorkspace Is Nothing) Then
    Dim pFields As IFields
    Set pFields = CreateBasicFields(shapeType, hasM, hasZ, pSR)
  
    Dim pFClass As IFeatureClass
    Set pFClass = shapeWorkspace.CreateFeatureClass(sName, pFields, Nothing, Nothing, esriFTSimple, "Shape", "")
  
    Set CreateShapefile = pFClass
  End If
End Function


 ' Create minimal required fields for featureclass
Public Function CreateBasicFields(shapeType As esriGeometryType, hasM As Boolean, hasZ As Boolean, _
    pSpaRef As ISpatialReference) As IFields
  
  Dim pFlds As IFields
  Dim pFldsEdt As IFieldsEdit
  Set pFlds = New esriCore.Fields
  Set pFldsEdt = pFlds
  
  Dim pFld As IField
  Dim pFldEdt As IFieldEdit
  Set pFld = New esriCore.Field
  Set pFldEdt = pFld
    
  Dim pGeoDef As IGeometryDefEdit
  Set pGeoDef = New GeometryDef

  With pGeoDef
    .GeometryType = shapeType
    .hasM = hasM
    .hasZ = hasZ
    Set .SpatialReference = pSpaRef
  End With

  ' add oid field (access and sde) - must come before geometry field
  Set pFldEdt = New esriCore.Field
  With pFldEdt
    .name = "OID"
    .Type = esriFieldTypeOID
  End With
  pFldsEdt.AddField pFldEdt
  
  'add Geometry field
  Set pFldEdt = New esriCore.Field
  With pFldEdt
    .name = "Shape"
    .IsNullable = True
    .Type = esriFieldTypeGeometry
    Set .GeometryDef = pGeoDef
  End With
  pFldsEdt.AddField pFldEdt
  
  Set CreateBasicFields = pFldsEdt
End Function

Public Function OpenShapeFile(dir As String, name As String) As IFeatureClass
  Dim pWSFact As IWorkspaceFactory
  Dim connectionProperties As IPropertySet
  Dim pShapeWS As IFeatureWorkspace
  Dim isShapeWS As Boolean

  Set OpenShapeFile = Nothing
  
  Set pWSFact = New ShapefileWorkspaceFactory
  isShapeWS = pWSFact.IsWorkspace(dir)
  If (isShapeWS) Then
    On Error GoTo errhandler
    Set connectionProperties = New PropertySet
    connectionProperties.SetProperty "DATABASE", dir
    Set pShapeWS = pWSFact.Open(connectionProperties, 0)
    Dim pFClass As IFeatureClass
    Set pFClass = pShapeWS.OpenFeatureClass(name)
    Set OpenShapeFile = pFClass
  End If
errhandler:
End Function

Public Sub AddShapeToFeatureClass(pGeom As IGeometry, pFC As IFeatureClass)
  Dim pFeature As IFeature
  Set pFeature = pFC.CreateFeature
  Set pFeature.Shape = pGeom
  pFeature.Store

End Sub

Public Sub AddFCToScene(pFC As IFeatureClass, sLayerName As String)
    Dim pDoc As ISxDocument

    If Not TypeOf Application Is ISxApplication Then
        Exit Sub
    End If
    
    ' Create a layer from the shapefile and add it to scene:
    Dim pLayer As IFeatureLayer
    Set pLayer = New FeatureLayer
    Set pLayer.FeatureClass = pFC
    pLayer.name = sLayerName
        
    Set pDoc = Application.Document
    ' Add layer to scene.
    Dim pBasicMap As IBasicMap
    Set pBasicMap = pDoc.Scene
    pBasicMap.AddLayer pLayer
  
    Dim pSG As ISceneGraph
    Set pSG = pDoc.Scene.SceneGraph
    pSG.RefreshViewers
    
End Sub