Cylinder 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 cylinder geometry.

How to use:
  1. Copy all of the code in this tip into a VBA module of ArcScene.
  2. Call the 'Cylinder' 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 'AddCylinder' 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 Cylinder( _
  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 Cylinder = 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 Cylinder = 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 Cylinder = pMultiPatch
  Exit Function
  Set Cylinder = 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 AddCylinder()

   'create a smooth cylinder:
    Dim pPt As esriCore.IPoint
    Set pPt = New Point: pPt.X = 0: pPt.Y = 0: pPt.Z = 5

    Dim pMP4 As esriCore.IMultiPatch
    Set pMP4 = Cylinder(pPt, 5, 0, 360, 0, 10, 36, Nothing, True)
    If pMP4 Is Nothing Then
        MsgBox "The MultiPatch is 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 pFCls4 As esriCore.IFeatureClass
        Set pFCls4 = CreateShapefile("c:\temp", "aCylinder.shp", esriGeometryMultiPatch, True, True, pSR)
	  'add the multipatch to the feature class:
        AddShapeToFeatureClass pMP4, pFCls4
	  'add this feature class to the scene as a new layer:
        AddFCToScene pFCls4, "aCylinder"
    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