创建Multipatch三维图形

创建Multipatch三维图形
Multipatch对象学习，3D建模
Multipatch是一系列几何对象组成的 可以表示3D效果的对象实体。
其中组成Multipatch的几何对象大致可以分为以下几种：
1，三角带；2，三角扇形；3，环状（内环和外环）；
通过IMultipatch接口可以控制并创建一个Multipatch对象，这个接口提供了多种具体的方法和实现属性；
同时也可以使用IConstructMultiPatch接口来进行Multipatch的创建工作，
如下六个方法依据不同的方式进行创建Multipatch（Extrude为压缩的意思）：
ConstructExtrude  
ConstructExtrudeAbsolute
ConstructExtrudeAlongLine
ConstructExtrudeBetween
ConstructExtrudeFromTo
ConstructExtrudeRelative
IGeneralMultiPatchCreator这个接口是用来创建具有纹理信息的Multipatch对象的，也就是所谓的textured纹理Multipatch对象；
当依据上述接口、方法创建完Multipatch后，可以使用IGeneralMultiPatchInfo 接口来对所创建的Multipatch进行信息查询，
如组成Multipatch的几何图形信息，个数，类型等等

这两天研究了Multipatch，自己创建了一个简单的3D模型在ArSence下，对Multipatch有了新的认识，整理一下学习笔记，希望和大家一起学习.
说明如下：
目的：创建一个简单Multipatch对象模型。
开发环境：ArSence下的VBA
实现效果：一个3D房子模型。
代码如下所示：
1。  ''VBA下的按钮实现函数
''当按钮点击事件发生时将调用  GetMultipatch函数，以便创建三维模型
Private Sub UIButtonControl1_Click()    
    Call GetMultipatch           
End Sub
2。GetMultipatch函数实现过程
''这个函数中首先需要创建3D符号，所以需要调用IMarker3DSymbol接口实现
''然后将创建好的IMarker3DSymbol符号作为一个Element元素添加到Sence的地图窗口中
Public Sub GetMultipatch()
  ''创建新的3D符号
  Dim pMarker3DSymbol As IMarker3DSymbol: Set pMarker3DSymbol = New Marker3DSymbol
  Set pMarker3DSymbol.Shape = GetGeometry()        ''设置3D符号几何形体(Multipatch)

  ''AppRef为当前正在运行的应用程序
  ''需要注意的是，本实例所创建的3DMultipatch是一个点的3DSymbol，所以使用Point创建
  Dim pSxApp As IApplication: Set pSxApp = New AppRef    ''获取当前地图应用程序Application
  Dim pPt As IPoint: Set pPt = New Point: pPt.X = 0#: pPt.Y = 0#: pPt.Z = 0#
  AddGraphic pSxApp, pPt, pMarker3DSymbol, , False    ''设定坐标原点，并加入Element对象元素
 
End Sub
3。''创建3D符号填充的几何形体，使用  GetGeometry函数实现，具体如下所示；
Function GetGeometry() As IGeometry
''创建Multipatch的点对象
    ''创建第一个Part中的点对象(东面的墙)
    Dim pT1 As IPoint, pT2 As IPoint, pT3 As IPoint, pT4 As IPoint
    Set pT1 = New Point
    pT1.X = 10: pT1.Y = 0:  pT1.Z = 0
    Set pT2 = New Point
    pT2.X = 10: pT2.Y = 0:  pT2.Z = 3
    Set pT3 = New Point
    pT3.X = 10: pT3.Y = 6:  pT3.Z = 3
    Set pT4 = New Point
    pT4.X = 10: pT4.Y = 6: pT4.Z = 0
    ''创建第二个Part中的点对象(北面的墙)
    Dim ppt1 As IPoint, ppt2 As IPoint
    Set ppt1 = New Point
    ppt1.X = 0: ppt1.Y = 6: ppt1.Z = 0
    Set ppt2 = New Point
    ppt2.X = 0: ppt2.Y = 6: ppt2.Z = 3
    ''创建第三个Part中的点对象（西面的墙）
    Dim ppt3 As IPoint, ppt4 As IPoint
    Set ppt3 = New Point
    ppt3.X = 0: ppt3.Y = 0: ppt3.Z = 3
    Set ppt4 = New Point
    ppt4.X = 0: ppt4.Y = 0: ppt4.Z = 0
    ''创建第四个Part中的点对象（南面的墙）
    ''其中南面的墙也是正面的，设计了一个门和一个窗户
    ''所以第四部分是由外环和内环组成的（本例子中窗子作为了内环处理的）
    ''下面是创建外环的点对象
    Dim inpt1 As IPoint, inpt2 As IPoint, inpt3 As IPoint, inpt4 As IPoint
    Set inpt1 = New Point
    Set inpt2 = New Point
    Set inpt3 = New Point
    Set inpt4 = New Point
    ''创建门组成的点
    inpt1.X = 2: inpt1.Y = 0: inpt1.Z = 0
    inpt2.X = 2: inpt2.Y = 0: inpt2.Z = 2
    inpt3.X = 4: inpt3.Y = 0: inpt3.Z = 2
    inpt4.X = 4: inpt4.Y = 0: inpt4.Z = 0
    ''创建第五部分 内环窗子的组成点对象
    Dim interpt1 As IPoint, interpt2 As IPoint, interpt3 As IPoint, interpt4 As IPoint
    Set interpt1 = New Point
    Set interpt2 = New Point
    Set interpt3 = New Point
    Set interpt4 = New Point
    interpt1.X = 6: interpt1.Y = 0: interpt1.Z = 1
    interpt2.X = 6: interpt2.Y = 0: interpt2.Z = 2
    interpt3.X = 8: interpt3.Y = 0: interpt3.Z = 2
    interpt4.X = 8: interpt4.Y = 0: interpt4.Z = 1
    ''创建第六、七、八、九部分 构建房顶 三角形 的点对象
    Dim pRoofTop As IPoint
    Dim pRoofD1 As IPoint, pRoofD2 As IPoint, pRoofD3 As IPoint, pRoofD4 As IPoint

    Set pRoofTop = New Point: Set pRoofD2 = New Point
    Set pRoofD1 = New Point: Set pRoofD3 = New Point: Set pRoofD4 = New Point
    pRoofTop.X = 5: pRoofTop.Y = 3: pRoofTop.Z = 5
    pRoofD1.X = 10: pRoofD1.Y = 0: pRoofD1.Z = 3
    pRoofD2.X = 10: pRoofD2.Y = 6: pRoofD2.Z = 3
    pRoofD3.X = 0: pRoofD3.Y = 6: pRoofD3.Z = 3
    pRoofD4.X = 0: pRoofD4.Y = 0: pRoofD4.Z = 3
    ''以下的点对象是用来创建 纹理贴图使用的，表示纹理图片的贴图的位置
    Dim s As Integer, t As Integer
    s = 1: t = 10
    Dim pTxLL0 As IPoint, pTxLR0 As IPoint, pTxUR0 As IPoint, pTxUL0 As IPoint
    Set pTxLL0 = New Point: Set pTxLR0 = New Point: Set pTxUR0 = New Point:: Set pTxUL0 = New Point
    pTxUL0.X = 6#: pTxUL0.Y = 0#: pTxUR0.X = s: pTxUR0.Y = 0#
    pTxLL0.X = 6#: pTxLL0.Y = t: pTxLR0.X = s: pTxLR0.Y = t
   
    ''创建Multipatch几何形体对象
    ''使用pGenralMultipatch对象进行初始化所要创建的几何对象要素
    ''首先需要使用Init方法来初始化Multipatch，使用IGeneralMultiPatchCreator接口
    Dim pGenralMultipatch As IGeneralMultiPatchCreator
    Set pGenralMultipatch = New GeneralMultiPatchCreator
    ''本实例中Init方法有以下几个参数，解释如下：
    ''41表示Multipatch所包含的点的个数，本实例所创建的房子对象需要41个点对象。包括重复的点对象，如两个面的相交面 公用的点也需要重新计算近来
    ''9表示Multipatch对象包含的部分数量，本实例中包含东、西、南、北、前面前的内环窗子部分、以及四个屋顶的三角扇形部分，共9个
    ''参数中的3个False可以采用默认的方式
    ''39表示的是纹理贴图所用的点数，一般情况下是与Multipatch所包含点个数是相同的；这个数量可以控制纹理贴图效果；
    ''GetMateriallist函数是添加纹理图像的函数，本例子中共添加了7个bmp格式的影像
    pGenralMultipatch.Init 41, 9, False, False, True, 39, GetMaterialList
   
    Dim dictWalls As Scripting.Dictionary: Set dictWalls = GetWall
    ''创建第一个部分，其中 第一个0表示创建的部分，第二个0表示贴纹理所使用的纹理序号，第3，4个表示纹理贴图的点号
    ''其中PartSetUp表示创建Multipatch的part设置
    ''说明如下：pGenralMultipatch为当前的Multipatch对象
    ''esriPatchTypeRing表示所创建的类型
    ''第一个0表示创建的部分序号
    ''第二个0表示纹理序号
    ''第3，4个表示纹理点对象序号
    PartSetUp pGenralMultipatch, 0, esriPatchTypeRing, 0, 0, 0
    ''表示对当前部分进行点对象的设置
    ''参数说明如下：pGenralMultipatch为当前的Multipatch对象
    ''第一个数字参数表示当前这个部分所包含的点的序号，第二个参数表示当前部分所包含的点
    ''第三个参数表示纹理贴图所包含的点
    PointSetUp pGenralMultipatch, 0, pT1, pTxLL0
    PointSetUp pGenralMultipatch, 1, pT2, pTxLR0
    PointSetUp pGenralMultipatch, 2, pT3, pTxUR0
    PointSetUp pGenralMultipatch, 3, pT4, pTxUL0
    PointSetUp pGenralMultipatch, 4, pT1, pTxLL0
    ''创建第2个部分
    PartSetUp pGenralMultipatch, 1, esriPatchTypeRing, 1, 5, 5
    PointSetUp pGenralMultipatch, 5, pT3, pTxLL0
    PointSetUp pGenralMultipatch, 6, pT4, pTxLR0
    PointSetUp pGenralMultipatch, 7, ppt1, pTxUR0
    PointSetUp pGenralMultipatch, 8, ppt2, pTxUL0
    PointSetUp pGenralMultipatch, 9, pT3, pTxLL0
    Set GetGeometry = pGenralMultipatch.CreateMultiPatch
    ''创建第3个部分
    PartSetUp pGenralMultipatch, 2, esriPatchTypeRing, 2, 10, 10
   
    PointSetUp pGenralMultipatch, 10, ppt1, pTxLL0
    PointSetUp pGenralMultipatch, 11, ppt2, pTxLR0
    PointSetUp pGenralMultipatch, 12, ppt3, pTxUR0
    PointSetUp pGenralMultipatch, 13, ppt4, pTxUL0
    PointSetUp pGenralMultipatch, 14, ppt1, pTxLL0
    Set GetGeometry = pGenralMultipatch.CreateMultiPatch
    ''4个部分
    PartSetUp pGenralMultipatch, 3, esriPatchTypeOuterRing, 3, 15, 15
    PointSetUp pGenralMultipatch, 15, ppt3, pTxLL0
    PointSetUp pGenralMultipatch, 16, ppt4, pTxLR0
    PointSetUp pGenralMultipatch, 17, inpt1, pTxUR0
    PointSetUp pGenralMultipatch, 18, inpt2, pTxUL0
    PointSetUp pGenralMultipatch, 19, inpt3, pTxLL0
    PointSetUp pGenralMultipatch, 20, inpt4, inpt4
    PointSetUp pGenralMultipatch, 21, pT1, pT1
    PointSetUp pGenralMultipatch, 22, pT2, pT2
    PointSetUp pGenralMultipatch, 23, ppt3, ppt3
    Set GetGeometry = pGenralMultipatch.CreateMultiPatch
    ''5个部分
    PartSetUp pGenralMultipatch, 4, esriPatchTypeInnerRing, -1, 24, 24
    PointSetUp pGenralMultipatch, 24, interpt1, interpt1
    PointSetUp pGenralMultipatch, 25, interpt2, interpt2
    PointSetUp pGenralMultipatch, 26, interpt3, interpt3
    PointSetUp pGenralMultipatch, 27, interpt4, interpt4
    PointSetUp pGenralMultipatch, 28, interpt1, interpt1
    ''第6个部分
    PartSetUp pGenralMultipatch, 5, esriPatchTypeTriangles, 5, 29, 29
    PointSetUp pGenralMultipatch, 29, pRoofTop, pRoofTop
    PointSetUp pGenralMultipatch, 30, pRoofD1, pRoofD1
    PointSetUp pGenralMultipatch, 31, pRoofD2, pRoofD2
    ''第7个部分
    PartSetUp pGenralMultipatch, 6, esriPatchTypeTriangles, 4, 32, 32
    PointSetUp pGenralMultipatch, 32, pRoofTop, pRoofTop
    PointSetUp pGenralMultipatch, 33, pRoofD2, pRoofD2
    PointSetUp pGenralMultipatch, 34, pRoofD3, pRoofD3
    ''第8个部分

 

PartSetUp pGenralMultipatch, 7, esriPatchTypeTriangles, 5, 35, 35
    PointSetUp pGenralMultipatch, 35, pRoofTop, pRoofTop
    PointSetUp pGenralMultipatch, 36, pRoofD3, pRoofD3
    PointSetUp pGenralMultipatch, 37, pRoofD4, pRoofD4
    ''第9个部分
    PartSetUp pGenralMultipatch, 8, esriPatchTypeTriangles, 0, 38, 38
    PointSetUp pGenralMultipatch, 38, pRoofTop, pRoofTop
    PointSetUp pGenralMultipatch, 39, pRoofD4, pRoofD4
    PointSetUp pGenralMultipatch, 40, pRoofD1, pRoofD1
    ''创建Multipatch对象
    Set GetGeometry = pGenralMultipatch.CreateMultiPatch
End Function
4。''向IGeometryMaterial中添加纹理图片
''以后以便向part中添加这个图片纹理
'The texture images are saved in a sub-folder called TextureFolder under the ArcScene document:
Function GetMaterialList() As IGeometryMaterialList
On Error GoTo eh

  'create new materials:
  ''纹理存放的路径
  Dim sTexFolder As String: sTexFolder = "D:\ArcGIS\DeveloperKit\SamplesCOM\3D_Analyst\TexturedMultipatchVisual_Basic\TexturedMultipatchVisual_Basic\Visual_Basic\TextureFolder\"

  'material 1:
  Dim pMaterial1 As IGeometryMaterial: Set pMaterial1 = New GeometryMaterial
  pMaterial1.TextureImage = sTexFolder & "tile_roo.jpg"   'the mission tile

'  material 2:
  Dim pMaterial2 As IGeometryMaterial: Set pMaterial2 = New GeometryMaterial
  pMaterial2.TextureImage = sTexFolder & "block2.jpg"

'  material 3:
  Dim pMaterial3 As IGeometryMaterial: Set pMaterial3 = New GeometryMaterial
  pMaterial3.TextureImage = sTexFolder & "brick1.jpg"

  'material 4:
  Dim pMaterial4 As IGeometryMaterial: Set pMaterial4 = New GeometryMaterial
  pMaterial4.TextureImage = sTexFolder & "concrete1.jpg"

  'material 5:
  Dim pMaterial5 As IGeometryMaterial: Set pMaterial5 = New GeometryMaterial
  pMaterial5.TextureImage = sTexFolder & "stucco3.jpg"

  'material 6:
  Dim pMaterial6 As IGeometryMaterial: Set pMaterial6 = New GeometryMaterial
  'pMaterial6.TextureImage = sTexFolder & "dessau.jpg"
  pMaterial6.TextureImage = sTexFolder & "worlitz.jpg"
  
  'create a new material list and add the material to the material list:
  Set GetMaterialList = New GeometryMaterialList
  GetMaterialList.AddMaterial pMaterial1
  GetMaterialList.AddMaterial pMaterial2
  GetMaterialList.AddMaterial pMaterial3
  GetMaterialList.AddMaterial pMaterial4
  GetMaterialList.AddMaterial pMaterial5
  GetMaterialList.AddMaterial pMaterial6
End Function
5，第五部分
''设置Part每个部分的属性信息
''具体参数如下PartSetUp函数所示：
''pCreator为创建Multipatch的对象，partIndex表示部分part的索引号，parttype表示part部分的类型信息，materialindex表示texture（纹理）的索引号
''partPointIndex表示当前所要设置part的点的组成，partTexturePointIndex表示当前part的纹理贴图所用的点的索引号
Public Sub PartSetUp(ByRef pCreator As IGeneralMultiPatchCreator, _
          partIndex As Integer, partType As esriPatchType, materialIndex As Integer, _
          partPointIndex As Integer, Optional partTexturePointIndex As Integer)
  With pCreator
    .SetPatchType partIndex, partType
    .SetMaterialIndex partIndex, materialIndex
    .SetPatchPointIndex partIndex, partPointIndex
    If Not IsMissing(partTexturePointIndex) Then
      .SetPatchTexturePointIndex partIndex, partTexturePointIndex
    End If
  End With
End Sub
6，第六部分
'‘设置点的属性信息:
''参数如下所示：
''pCreator表示当前创建MultiPatch的对象，pointIndex表示点的索引号
Public Sub PointSetUp(ByRef pCreator As IGeneralMultiPatchCreator, _
              pointIndex As Integer, pPtZ As IPoint, Optional pTexPt As IPoint = Nothing)
  pCreator.SetPoint pointIndex, pPtZ
  If Not pTexPt Is Nothing Then pCreator.SetTexturePoint pointIndex, pTexPt
End Sub
7，第七部分
''添加Multipatch 为element，并显示在sence上
Public Sub AddGraphic(pApp As IApplication, _
  pGeom As IGeometry, _
  Optional pSym As ISymbol, _
  Optional bAddToSelection As Boolean = False, _
  Optional bSelect As Boolean = True, _
  Optional sElementName As String) ' TODO this needs to change

  On Error GoTo AddGraphic_ERR

  If pGeom.IsEmpty Then Exit Sub

  Dim pElement As IElement

  Select Case pGeom.GeometryType
    Case esriGeometryPoint
      Set pElement = New MarkerElement
      Dim pPointElement As IMarkerElement: Set pPointElement = pElement
      If Not pSym Is Nothing Then pPointElement.Symbol = pSym
    Case esriGeometryPolyline
      Set pElement = New LineElement
      Dim pLineElement As ILineElement: Set pLineElement = pElement
      If Not pSym Is Nothing Then pLineElement.Symbol = pSym
    Case esriGeometryPolygon
      Set pElement = New PolygonElement
      Dim pFillElement As IFillShapeElement: Set pFillElement = pElement
      If Not pSym Is Nothing Then pFillElement.Symbol = pSym
    Case esriGeometryMultiPatch
      Set pElement = New MultiPatchElement
      Set pFillElement = pElement
      If Not pSym Is Nothing Then pFillElement.Symbol = pSym
  End Select

  pElement.Geometry = pGeom
  If Len(sElementName) > 0 Then
    Dim pElemProps As IElementProperties: Set pElemProps = pElement
    pElemProps.Name = sElementName
  End If

  Dim pGLayer As IGraphicsLayer
  If (TypeOf pApp Is IMxApplication) Then
    Dim pMxDoc As IMxDocument: Set pMxDoc = pApp.Document
    Dim pActiveView As IActiveView: Set pActiveView = pMxDoc.FocusMap
    Set pGLayer = pMxDoc.FocusMap.BasicGraphicsLayer
    Dim pGCon As IGraphicsContainer: Set pGCon = pGLayer

    pGCon.AddElement pElement, 0

    Dim pGCS As IGraphicsContainerSelect
    Set pGCS = pGCon
    ' unselect all other elements before selecting this one:
    If Not bAddToSelection Then pGCS.UnselectAllElements
    pGCS.SelectElement pElement

    ' redraw graphics for entire view extent, rather than just extent of this element, in case there were
    ' other graphics present that became unselected and lost their selection handles
    pActiveView.PartialRefresh esriViewGraphics, pElement, pActiveView.Extent
  Else
    Dim pSxDoc As ISxDocument: Set pSxDoc = pApp.Document
    Set pGLayer = pSxDoc.Scene.BasicGraphicsLayer
    'set lighting to true:
    Dim pLyrExt As ILayerExtensions: Set pLyrExt = pGLayer
    Dim p3DProp As I3DProperties: Set p3DProp = pLyrExt.Extension(0)
    p3DProp.Illuminate = False
    Dim pGCon3D As IGraphicsContainer3D: Set pGCon3D = pGLayer

    pGCon3D.DeleteAllElements
    pGCon3D.AddElement pElement

    Dim pGS As IGraphicsSelection: Set pGS = pGCon3D
    If (bSelect) Then
      ' unselect all other elements before selecting this one
      If Not bAddToSelection Then pGS.UnselectAllElements
      pGS.SelectElement pElement
    End If

    pSxDoc.Scene.SceneGraph.RefreshViewers
  End If

  Exit Sub
AddGraphic_ERR:
  Debug.Print "AddGraphic_ERR: " & Err.Description
  Debug.Assert 0
End Sub

''注意事项：
''Multipatch其实是表示多个几何要素所组成的格外一个几何对象，大多情况下是带有高程值的
''在上述的例子中，一个Multipatch所表示的就是由四个矩形和4个三角形所组成的
''当我们想为一个不带有高程信息的一个平面对象赋予一定的纹理的时候，一定要设置组成平面的点的Z值；Z=0才能显示出来；
''同时，还需要注意pGenralMultipatch.Init 41, 9, False, False, True, 39, GetMaterialList这条语句，里面的数字参数设置会改变一定的显示效果，需要注意；
''还有就是要 注意PartSetUp pGenralMultipatch, 4, esriPatchTypeInnerRing, -1, 24, 24
                 PointSetUp pGenralMultipatch, 24, interpt1, interpt1
''设置part与point的函数参数

 

使用方法：打开ARcscene，打开tool-macros-visualbasic Editer

在Project的ArcSceneObjects的ThisDocument上双击，然后将下列代码贴入：运行之后便会形成房屋形状。