ArcObjects Library Reference  (3DAnalyst)    

IGeneralMultiPatchCreator Example

[Visual Basic 6.0]

 

' Run the TestMultipatch routine in a standard module in ArcScene's VBA IDE

' and it'll create a simple cube 3D marker symbol element made from a

' textured multipatch in scene.  You need to specify your own four images

' (different images with different formats preferred) in the GetMaterialList

' routine to start. After the multipatch graphics is added to the scene, you

' may use the graphics selector tool to select it and view it in a wireframe.

 

Sub TestMultipatch()

  Dim pSxDoc As ISxDocument: Set pSxDoc = ThisDocument
  Dim pScene As IScene: Set pScene = pSxDoc.Scene
 
  Dim pMarker3DSymbol As esri3DAnalyst.IMarker3DSymbol
  Set pMarker3DSymbol = GetCubeSymbol
 
  Dim pPt As IPoint: Set pPt = New Point: pPt.x = 0#: pPt.Y = 0#: pPt.z = 0#
  AddGraphic pScene, pPt, pMarker3DSymbol

End Sub

Private Function GetCubeSymbol() As IMarker3DSymbol
On Error GoTo EH
 
  ' Prepare 4 square panels (a panel is a vertical polygon here; 4 panels are the 4 sides of a cube):
  Dim pPt As IPoint: Set pPt = New Point: pPt.x = 0#: pPt.Y = 0#: pPt.z = 0#
  Dim pPatch As IMultiPatch: Set pPatch = SimpleCube(pPt, 9)
  Dim pPanel1 As IPointCollection: Set pPanel1 = GetPanel(1, pPatch)  'contains 4 points
  Dim pPanel2 As IPointCollection: Set pPanel2 = GetPanel(2, pPatch)  'contains 4 points
  Dim pPanel3 As IPointCollection: Set pPanel3 = GetPanel(3, pPatch)  'contains 4 points
  Dim pPanel4 As IPointCollection: Set pPanel4 = GetPanel(4, pPatch)  'contains 4 points

  ' Set the texture coordinates for a panel.
  ' The texture coords control how the texture is repeated in the panel.
  ' Pay attention to the coordinates of the first panel.
  Dim pTxLL As WKSPoint, pTxLR As WKSPoint, pTxUR As WKSPoint, pTxUL As WKSPoint
  pTxUL.x = 0#: pTxUL.Y = 0#: pTxUR.x = 1#: pTxUR.Y = 0#
  pTxLL.x = 0#: pTxLL.Y = 1#:  pTxLR.x = 1#: pTxLR.Y = 1#
  Dim pTxLL2 As WKSPoint, pTxLR2 As WKSPoint, pTxUR2 As WKSPoint, pTxUL2 As WKSPoint
  pTxUL2.x = 0#: pTxUR2.Y = 0#: pTxUR2.x = 2#: pTxUR2.Y = 0#
  pTxLL2.x = 0#: pTxLL2.Y = 2#: pTxLR2.x = 2#: pTxLR2.Y = 2#
  Dim pTxLL3 As WKSPoint, pTxLR3 As WKSPoint, pTxUR3 As WKSPoint, pTxUL3 As WKSPoint
  pTxUL3.x = 0#: pTxUR3.Y = 0#: pTxUR3.x = 3#: pTxUR3.Y = 0#
  pTxLL3.x = 0#: pTxLL3.Y = 3#: pTxLR3.x = 3#: pTxLR3.Y = 3#
  Dim pTxLL4 As WKSPoint, pTxLR4 As WKSPoint, pTxUR4 As WKSPoint, pTxUL4 As WKSPoint
  pTxUL4.x = 0#: pTxUR4.Y = 0#: pTxUR4.x = 2#: pTxUR4.Y = 0#
  pTxLL4.x = 0#: pTxLL4.Y = 3#: pTxLR4.x = 2#: pTxLR4.Y = 3#
    
  ' Store the vertices of the four panels.
  ' The panel coordinates control where the textured is located.
  Dim pPlane1_UL As WKSPointZ, pPlane1_UR As WKSPointZ
  Dim pPlane1_LL As WKSPointZ, pPlane1_LR As WKSPointZ
  With pPanel1
    pPlane1_UL.x = 4 + .Point(1).x / 5: pPlane1_UL.Y = .Point(1).Y: pPlane1_UL.z = .Point(1).z
    pPlane1_UR.x = 4 + .Point(3).x / 5: pPlane1_UR.Y = .Point(3).Y: pPlane1_UR.z = .Point(3).z
    pPlane1_LL.x = 4 + .Point(0).x / 5: pPlane1_LL.Y = .Point(0).Y: pPlane1_LL.z = .Point(0).z + 3
    pPlane1_LR.x = 4 + .Point(2).x / 5: pPlane1_LR.Y = .Point(2).Y: pPlane1_LR.z = .Point(2).z + 3
  End With
  Dim pPlane2_UL As WKSPointZ, pPlane2_UR As WKSPointZ
  Dim pPlane2_LL As WKSPointZ, pPlane2_LR As WKSPointZ
  With pPanel2
    pPlane2_UL.x = .Point(1).x: pPlane2_UL.Y = 3 + .Point(1).Y / 3: pPlane2_UL.z = 3 + .Point(1).z / 3
    pPlane2_UR.x = .Point(3).x: pPlane2_UR.Y = 3 + .Point(3).Y / 3: pPlane2_UR.z = 3 + .Point(3).z / 3
    pPlane2_LL.x = .Point(0).x: pPlane2_LL.Y = 3 + .Point(0).Y / 3: pPlane2_LL.z = 3 + .Point(0).z / 3
    pPlane2_LR.x = .Point(2).x: pPlane2_LR.Y = 3 + .Point(2).Y / 3: pPlane2_LR.z = 3 + .Point(2).z / 3
  End With
  Dim pPlane3_UL As WKSPointZ, pPlane3_UR As WKSPointZ
  Dim pPlane3_LL As WKSPointZ, pPlane3_LR As WKSPointZ
  With pPanel3
    pPlane3_UL.x = .Point(1).x * 2 / 3: pPlane3_UL.Y = .Point(1).Y: pPlane3_UL.z = .Point(1).z * 2 / 3
    pPlane3_UR.x = .Point(3).x * 2 / 3: pPlane3_UR.Y = .Point(3).Y: pPlane3_UR.z = .Point(3).z * 2 / 3
    pPlane3_LL.x = .Point(0).x * 2 / 3: pPlane3_LL.Y = .Point(0).Y: pPlane3_LL.z = .Point(0).z * 2 / 3
    pPlane3_LR.x = .Point(2).x * 2 / 3: pPlane3_LR.Y = .Point(2).Y: pPlane3_LR.z = .Point(2).z * 2 / 3
  End With
  Dim pPlane4_UL As WKSPointZ, pPlane4_UR As WKSPointZ
  Dim pPlane4_LL As WKSPointZ, pPlane4_LR As WKSPointZ
  With pPanel4
    pPlane4_UL.x = .Point(1).x: pPlane4_UL.Y = .Point(1).Y: pPlane4_UL.z = .Point(1).z
    pPlane4_UR.x = .Point(3).x: pPlane4_UR.Y = .Point(3).Y: pPlane4_UR.z = .Point(3).z
    pPlane4_LL.x = .Point(0).x: pPlane4_LL.Y = .Point(0).Y: pPlane4_LL.z = .Point(0).z
    pPlane4_LR.x = .Point(2).x: pPlane4_LR.Y = .Point(2).Y: pPlane4_LR.z = .Point(2).z
  End With

  ' Make the new multipatch creator:
  Dim pCreator As IGeneralMultiPatchCreator: Set pCreator = New GeneralMultiPatchCreator
  pCreator.Init 20, 4, False, False, False, 20, GetMaterialList
  ' Create a multipatch that contains 20 points, 4 parts, no Ms, no IDs, no Normals, with 20 texture points
  ' textured from textures in a material list.
  ' Note: Number of texture points always less or equal to the number of points.
 
  ' Initialize the geometry creator: 4 points per panel + duplicate origin vertice = 5 per panel
  With pCreator
    .SetMaterialIndex 0, 0  '1st patch uses material 1.
    .SetMaterialIndex 1, 1
    .SetMaterialIndex 2, 2
    .SetMaterialIndex 3, 3
   
    .SetPatchPointIndex 0, 0  '1st patch geometry starts at the 1st vertex
    .SetPatchPointIndex 1, 5
    .SetPatchPointIndex 2, 10
    .SetPatchPointIndex 3, 15
 
    .SetPatchTexturePointIndex 0, 0 '1st panel texture coordinate starts at the 1st tecture coordinate
    .SetPatchTexturePointIndex 1, 5
    .SetPatchTexturePointIndex 2, 10
    .SetPatchTexturePointIndex 3, 15

    .SetPatchType 0, esriPatchTypeRing  '1st panel is a ring
    .SetPatchType 1, esriPatchTypeRing
    .SetPatchType 2, esriPatchTypeRing
    .SetPatchType 3, esriPatchTypeRing
   
    ' starting from the 1st panel:
    .SetTextureWKSPoint 0, pTxLL  'starting from lower left
    .SetTextureWKSPoint 1, pTxUL
    .SetTextureWKSPoint 2, pTxUR
    .SetTextureWKSPoint 3, pTxLR
    .SetTextureWKSPoint 4, pTxLL
    ' 2nd:
    .SetTextureWKSPoint 5, pTxLL2  'starting from lower left
    .SetTextureWKSPoint 6, pTxUL2
    .SetTextureWKSPoint 7, pTxUR2
    .SetTextureWKSPoint 8, pTxLR2
    .SetTextureWKSPoint 9, pTxLL2
    ' 3rd:
    .SetTextureWKSPoint 10, pTxLL3  'starting from lower left
    .SetTextureWKSPoint 11, pTxUL3
    .SetTextureWKSPoint 12, pTxUR3
    .SetTextureWKSPoint 13, pTxLR3
    .SetTextureWKSPoint 14, pTxLL3
    ' 4th:
    .SetTextureWKSPoint 15, pTxLL4  'starting from lower left
    .SetTextureWKSPoint 16, pTxUL4
    .SetTextureWKSPoint 17, pTxUR4
    .SetTextureWKSPoint 18, pTxLR4
    .SetTextureWKSPoint 19, pTxLL4
   
    ' set the vertices for the 1st panel:
    .SetWKSPointZ 0, pPlane1_LL  'starting from lower left
    .SetWKSPointZ 1, pPlane1_UL
    .SetWKSPointZ 2, pPlane1_UR
    .SetWKSPointZ 3, pPlane1_LR
    .SetWKSPointZ 4, pPlane1_LL
    ' 2nd:
    .SetWKSPointZ 5, pPlane2_LL  'starting from lower left
    .SetWKSPointZ 6, pPlane2_UL
    .SetWKSPointZ 7, pPlane2_UR
    .SetWKSPointZ 8, pPlane2_LR
    .SetWKSPointZ 9, pPlane2_LL
    ' 3rd:
    .SetWKSPointZ 10, pPlane3_LL  'starting from lower left
    .SetWKSPointZ 11, pPlane3_UL
    .SetWKSPointZ 12, pPlane3_UR
    .SetWKSPointZ 13, pPlane3_LR
    .SetWKSPointZ 14, pPlane3_LL
    ' 4th:
    .SetWKSPointZ 15, pPlane4_LL  'starting from lower left
    .SetWKSPointZ 16, pPlane4_UL
    .SetWKSPointZ 17, pPlane4_UR
    .SetWKSPointZ 18, pPlane4_LR
    .SetWKSPointZ 19, pPlane4_LL
   
  End With

  ' Build the Multipatch (this part has to be done AFTER all the basics are set):
  Dim pGeometry As IGeometry: Set pGeometry = pCreator.CreateMultiPatch
 
  ' Instantiate a new marker 3D symbol:
  Dim pMarker3DSymbol As IMarker3DSymbol: Set pMarker3DSymbol = New Marker3DSymbol
  ' Set the shape of the marker symbol to the new multipatch:
  Set pMarker3DSymbol.Shape = pGeometry
   
  ' Return the symbol:
  Set GetCubeSymbol = pMarker3DSymbol

cleanup:
  Set pCreator = Nothing
  Set pGeometry = Nothing
  Set pMarker3DSymbol = Nothing
Exit Function
EH:
  MsgBox Err.Number & ": " & Err.Description, vbExclamation, "GetCubeSymbol()"
  GoTo cleanup
End Function

'Make a simple cube multipatch with LL origin set to pOrigin and with equal side of dSide.
'No top and bottom sides, yet.  Only 4 sides.
Private Function SimpleCube(ByVal pOrigin As IPoint, dSide As Double) As IMultiPatch
On Error GoTo EH
  Dim pStrip As IPointCollection: Set pStrip = New TriangleStrip
 
  'make the rest of the points (points 2-10):
  With pOrigin
    Dim pPt2 As IPoint: Set pPt2 = New Point: pPt2.x = .x: pPt2.Y = .Y: pPt2.z = .z + dSide
    Dim pPt3 As IPoint: Set pPt3 = New Point: pPt3.x = .x + dSide: pPt3.Y = .Y: pPt3.z = .z
    Dim pPt4 As IPoint: Set pPt4 = New Point: pPt4.x = .x + dSide: pPt4.Y = .Y: pPt4.z = .z + dSide
    Dim pPt5 As IPoint: Set pPt5 = New Point: pPt5.x = .x + dSide: pPt5.Y = .Y + dSide: pPt5.z = .z
    Dim pPt6 As IPoint: Set pPt6 = New Point: pPt6.x = .x + dSide: pPt6.Y = .Y + dSide: pPt6.z = .z + dSide
    Dim pPt7 As IPoint: Set pPt7 = New Point: pPt7.x = .x: pPt7.Y = .Y + dSide: pPt7.z = .z
    Dim pPt8 As IPoint: Set pPt8 = New Point: pPt8.x = .x: pPt8.Y = .Y + dSide: pPt8.z = .z + dSide
    Dim pPt9 As IPoint: Set pPt9 = New Point: pPt9.x = .x: pPt9.Y = .Y: pPt9.z = .z   'same as pOrigin
    Dim ppt10 As IPoint: Set ppt10 = New Point: ppt10.x = .x: ppt10.Y = .Y: ppt10.z = .z + dSide
  End With
 
  With pStrip
    .AddPoint pOrigin 'the beginning
    .AddPoint pPt2: .AddPoint pPt3: .AddPoint pPt4: .AddPoint pPt5
    .AddPoint pPt6: .AddPoint pPt7: .AddPoint pPt8: .AddPoint pPt9
    .AddPoint ppt10   'the end
  End With

  Set SimpleCube = New MultiPatch
  Dim pGeomCol As IGeometryCollection: Set pGeomCol = SimpleCube
  Dim pGeom As IGeometry: Set pGeom = pStrip
  pGeomCol.AddGeometry pGeom
 
Exit Function
EH:
  MsgBox Err.Number & ": " & Err.Description, vbExclamation, "SimpleCube()"
End Function

Private Function GetPanel(iNum As Integer, ByVal pPatch As IMultiPatch) As IPointCollection
  If iNum < 1 Or iNum > 4 Then Exit Function  'only accepts 4 sides at present
  Set GetPanel = New Polygon
  Dim i As Integer, iStart As Integer, iEnd As Integer
  iStart = 2 * (iNum - 1)
  iEnd = (2 * iNum) + 1
  Dim pPtCol As IPointCollection: Set pPtCol = pPatch
  For i = iStart To iEnd
    Dim pPt As IPoint: Set pPt = pPtCol.Point(i)
    GetPanel.AddPoint pPt
  Next i
End Function

' Make a material list that contains four texture images (a *.tif, a *.bmp, a *gif, and a *.jpg):
Private Function GetMaterialList() As IGeometryMaterialList
On Error GoTo EH

  ' Material 1:
  Dim pMaterial1 As esri3DAnalyst.IGeometryMaterial
  Set pMaterial1 = New esri3DAnalyst.GeometryMaterial
  pMaterial1.TextureImage = "filepath\image1.tif"

  
  ' Material 2:
  Dim pMaterial2 As esri3DAnalyst.IGeometryMaterial
  Set pMaterial2 = New esri3DAnalyst.GeometryMaterial
  pMaterial2.TextureImage = "filepath\image2.bmp"
 
  ' Material 3:
  Dim pMaterial3 As esri3DAnalyst.IGeometryMaterial
  Set pMaterial3 = New esri3DAnalyst.GeometryMaterial
  pMaterial3.TextureImage = "filepath\image3.gif"
 
  ' Material 4:
  Dim pMaterial4 As esri3DAnalyst.IGeometryMaterial
  Set pMaterial4 = New esri3DAnalyst.GeometryMaterial
  pMaterial4.TextureImage = "filepath\image4.jpg"
 
  ' Create a new material list and add the four materials to the material list:
  Set GetMaterialList = New esri3DAnalyst.GeometryMaterialList
  With GetMaterialList
    .AddMaterial pMaterial1
    .AddMaterial pMaterial2
    .AddMaterial pMaterial3
    .AddMaterial pMaterial4
  End With
 
cleanups:
  Set pMaterial1 = Nothing
  Set pMaterial2 = Nothing
  Set pMaterial3 = Nothing
  Set pMaterial4 = Nothing
 
Exit Function

EH:
  MsgBox Err.Number & ": " & Err.Description, vbExclamation, "GetMaterialList()"
  GoTo cleanups
 
End Function

' Add graphic to passed pApp, which is ArcScene.
' The graphic is added to the BasicGraphicsLayer of the scene.
Private Sub AddGraphic(pScene As IScene, pGeom As IGeometry, pSym As ISymbol)
On Error GoTo ER
 
  If pGeom.IsEmpty Or pSym Is Nothing Then Exit Sub
 
  Dim pElement As IElement: Set pElement = New MarkerElement
  Dim pPointElement As IMarkerElement: Set pPointElement = pElement
  pPointElement.Symbol = pSym
  pElement.Geometry = pGeom
 
  Dim pGLayer As IGraphicsLayer: Set pGLayer = pScene.BasicGraphicsLayer
  Dim pGCon3D As IGraphicsContainer3D: Set pGCon3D = pGLayer
  pGCon3D.DeleteAllElements   'clean up before adding new graphics
 
  pGCon3D.AddElement pElement
  pScene.SceneGraph.RefreshViewers
 
Exit Sub
 
ER:
  MsgBox Err.Number & ": " & Err.Description, vbExclamation, "AddGraphic()"
End Sub

 


[Visual Basic .NET, C#, C++]
No example is available for Visual Basic .NET, C#, or C++. To view a Visual Basic 6.0 example, click the Language Filter button Language Filter in the upper-left corner of the page.