创建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个部分
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上双击，然后将下列代码贴入：运行之后便会形成房屋形状。
