Pyramid Multipatch


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 a pyramid geometry.

How to use:
  1. Copy all of the code in this tip into a VBA module of ArcScene.
  2. Call the 'Pyramid' 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 'AddPyramid' 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 Pyramid( _
    pTop As esriCore.IPoint, _
    radius As Double, _
    minLon As Double, _
    maxLon As Double, _
    zPlaneHeight As Double, _
    iDivision As Integer, _
    Optional pCenter As esriCore.IPoint = Nothing) As esriCore.IMultiPatch
On Error GoTo EH

    Dim sampLon As Double
    sampLon = iDivision
    Dim dblStep As Double
    dblStep = (maxLon - minLon) / sampLon
    Dim pMP As esriCore.IMultiPatch
    Set pMP = New MultiPatch
    Dim pGCol As esriCore.IGeometryCollection
    Set pGCol = pMP
    Dim pFan As esriCore.IPointCollection
    Set pFan = New TriangleFan
    pFan.AddPoint pTop
    Dim pV3D As esriCore.IVector3D
    Set pV3D = New Vector3D
    Dim dblAngle As Double 'the inclination angle from top pt
    dblAngle = IIf(pTop.Z = 0, 0, Atn(radius / pTop.Z))
    Dim lon As Double
    Dim azi As Double
    Dim pt As esriCore.IPoint
    For lon = maxLon To minLon Step -dblStep     'pay attention to the order
        azi = DegreesToRadians(lon)
        pV3D.PolarSet azi, dblAngle, radius
        Set pt = New Point
        pt.X = pTop.X + pV3D.XComponent
        pt.Y = pTop.Y + pV3D.YComponent
        If Not (pCenter Is Nothing) Then
            If (pCenter.Z <> zPlaneHeight) Then
                MsgBox "The plane cannot be tilted."
                Set Pyramid = Nothing
                Exit Function
            End If
            pt.X = pt.X + pCenter.X
            pt.Y = pt.Y + pCenter.Y
        End If
        pt.Z = zPlaneHeight
        pFan.AddPoint pt
    Next lon
    pGCol.AddGeometry pFan
    Dim pZA As esriCore.IZAware
    Set pZA = pMP
    pZA.ZAware = True
    Dim pMA As esriCore.IMAware
    Set pMA = pMP
    pMA.MAware = True
    Set Pyramid = pMP
Exit Function
    Set Pyramid = 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 AddPyramid()

	'a pyramid:
    Dim pPt As esriCore.IPoint
    Set pPt = New Point: pPt.X = 0: pPt.Y = 0: pPt.Z = 5
    Dim pMP6 As esriCore.IMultiPatch
    Set pMP6 = Pyramid(pPt, 4, 0, 360, 0, 4)
    If pMP6 Is Nothing Then
        MsgBox "The MultiPatch was not created."
        Exit Sub
        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 pFCls6 As esriCore.IFeatureClass
        Set pFCls6 = CreateShapefile("c:\temp", "aPyramid.shp", esriGeometryMultiPatch, True, True, pSR)
        AddShapeToFeatureClass pMP6, pFCls6
        AddFCToScene pFCls6, "aPyramid"

    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 Sub AddShapeToFeatureClass(pGeom As IGeometry, pFC As IFeatureClass)
  Dim pFeature As IFeature
  Set pFeature = pFC.CreateFeature
  Set pFeature.Shape = pGeom

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 = 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
End Sub