Cube 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 cube, or Polyhedron geometry.

How to use:
  1. Copy all of the code in this tip into a VBA module of ArcScene.
  2. Call the 'Polyhedron' 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 'AddCube' 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 Polyhedron( _
  pOrigin As esriCore.IPoint, _
  radius As Double, _
  minLon As Double, _
  maxLon As Double, _
  zmin As Double, _
  zmax As Double, _
  iDivision As Integer, _
  Optional pOffCenter As esriCore.IPoint = Nothing, _
  Optional bSmooth As Boolean = False, _
  Optional bFlipS As Boolean = False, _
  Optional bFlipT As Boolean = False) As esriCore.IMultiPatch

  On Error GoTo EH

  Dim sampLon As Double
  sampLon = iDivision
  Dim xStep As Double
  Dim yStep As Double
  xStep = (maxLon - minLon) / sampLon

  Dim lonRange As Double
  lonRange = maxLon - minLon

  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
  Set pStrip = New TriangleStrip

  Dim pVector As IVector3D
  Set pVector = New Vector3D
  Dim pGE As IEncode3DProperties
  Set pGE = New GeometryEnvironment
  Dim lon As Double
  For lon = maxLon To minLon Step -xStep
    Dim azi As Double
    azi = DegreesToRadians(lon)
    pVector.PolarSet -azi, 0, radius
    Set pt = New esriCore.Point
    pt.X = pOrigin.X + pVector.XComponent
    pt.Y = pOrigin.Y + pVector.YComponent
    If (pOffCenter Is Nothing) Then     'apply possible smoothing when upright
        Dim m As Double
        m = 0
        If (bSmooth) Then
            Dim pV As esriCore.IVector3D
            Set pV = New Vector3D
            pV.SetComponents pt.X, pt.Y, 0
            pGE.PackNormal pV, m
            pt.m = m
        End If
        If (pOffCenter.Z = pOrigin.Z) Then
            MsgBox "The two point cannot be at the same height."
            Set Polyhedron = Nothing
            Exit Function
        End If
        If Not (pOffCenter.Z = zmin Or pOffCenter.Z = zmax) Then
            MsgBox "The second point height has to be the same as zMin or zMax."
            Set Polyhedron = Nothing
            Exit Function
        End If
        Dim pSubV As esriCore.IVector3D
        Set pSubV = New Vector3D
        pSubV.ConstructDifference pOffCenter, pOrigin
        pt.X = pt.X + pSubV.XComponent
        pt.Y = pt.Y + pSubV.YComponent
    End If
    pt.Z = zmin
    Dim s As Double
    s = (lon - minLon) / lonRange
    If (bFlipS) Then s = 1 + (s * -1)
    ' Due to floating point precision issues make sure
    ' texture coordinate in safe range.
    If (s <= 0) Then s = 0.001
    If (s >= 1) Then s = 0.999
    Dim t As Double
    t = IIf(bFlipT, 0, 1)
    pGE.PackTexture2D s, t, m
    pt.m = m
    pStrip.AddPoint pt

    Dim pt2 As IPoint
    Dim pClone As IClone
    Set pClone = pt
    Set pt2 = pClone.Clone
    If (pOffCenter Is Nothing) Then     'apply possible smoothing when upright
        If (bSmooth) Then pt2.m = m     'use the above calculated m
        Dim pSubV2 As esriCore.IVector3D
        Set pSubV2 = New Vector3D
        pSubV2.ConstructDifference pOrigin, pOffCenter
        pt2.X = pt2.X + pSubV2.XComponent
        pt2.Y = pt2.Y + pSubV2.YComponent
    End If
    pt2.Z = zmax
    t = IIf(bFlipT, 1, 0)
    m = 0
    pGE.PackTexture2D s, t, m
    pt2.m = m
    pStrip.AddPoint pt2
  Next lon

  Set pGeom = pStrip
  pGCol.AddGeometry pGeom

  Dim pZAware As IZAware
  Set pZAware = pMultiPatch
  pZAware.ZAware = True

  Dim pMAware As IMAware
  Set pMAware = pMultiPatch
  pMAware.MAware = True

  Set Polyhedron = pMultiPatch
  Exit Function
  Set Polyhedron = Nothing
End Function

'example usage:
Public Sub AddCube()
    'a topless and bottomless cube:
    Dim pPt As esriCore.IPoint
    Set pPt = New Point: pPt.X = 0: pPt.Y = 0: pPt.Z = 5

    Dim pMP2 As esriCore.IMultiPatch
    Set pMP2 = Polyhedron(pPt, 5, 0, 360, 0, 10, 4, Nothing, True)
    If pMP2 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 pFCls2 As esriCore.IFeatureClass
        Set pFCls2 = CreateShapefile("c:\temp\", "aCube.shp", esriGeometryMultiPatch, True, True, pSR)
        'add the mulitpatch to the shapefile:
        AddShapeToFeatureClass pMP2, pFCls2
        'add the feature class to the scene:
        AddFCToScene pFCls2, "aCube"
    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 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
End Function

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

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