在arcgis中用vba生成带z值的shapefile文件

<br>很多三维软件支持shapefile的直接导入，有些软件可以根据shape文件的某个高程字段自动拔起，有些软件是根据带z值的shape自动拔其，前者没什么好说的，后者值得写点东西</p>
<p>    在arcgis中用vba写，首先作一个带z值的空shapefiel，加载原始shape和新作的shape，原始shape要含高程字段（如果
统一赋值就没必要了，但这种情况不多），0层为原始shapefile，1层为新做的shapefile，代码如下：</p>
<p>Option Explicit</p>
<p>Private Sub addZ()<br>    Dim pMxDoc As IMxDocument<br>    Set pMxDoc = ThisDocument<br>    Dim pMap As IMap<br>    Set pMap = pMxDoc.FocusMap<br>    Dim player As IFeatureLayer<br>    Set player = pMap.Layer(0)<br>    Dim pFC As IFeatureClass<br>    Set pFC = player.FeatureClass<br>    <br>    Dim pCur As IFeatureCursor<br>    Set pCur = pFC.Search(Nothing, False)<br>    Dim pF As IFeature<br>    <br>    Dim player1 As IFeatureLayer<br>    Set player1 = pMap.Layer(1)<br>    Dim pFC1 As IFeatureClass<br>    Set pFC1 = player1.FeatureClass<br>    <br>    Dim pFeatBuffer As IFeatureBuffer<br>    Dim pF2 As IFeature<br>    Dim pFeatCursor As IFeatureCursor<br>    <br>'    Set pFeatBuffer = pFC1.CreateFeatureBuffer<br>'    Set pFeatCursor = pFC.Insert(True)<br>'    Set pF2 = pFeatBuffer<br>    <br>    Dim pPolygon1 As IPolygon<br>    Dim pGeometry As IGeometry<br>    Set pF = pCur.NextFeature<br>    Dim i As Long<br>    Do Until pF Is Nothing<br>'        i = i + 1<br>        Set pF2 = pFC1.CreateFeature<br>        Set pPolygon1 = pF.Shape<br>        Set pGeometry = pPolygon1<br>        SetShapeZConstant pGeometry, CDbl(pF.Value(7))<br>        Set pF2.Shape = pGeometry<br>        pF2.Value(2) = pF.Value(8)<br>        pF2.Store<br>        <br>'        pFeatCursor.InsertFeature pFeatBuffer<br>'        If i Mod 100 = 0 Then<br>'            pFeatCursor.Flush<br>'        End If</p>
<p>        Set pF = pCur.NextFeature<br>    Loop<br>    pFeatCursor.Flush<br>    MsgBox "OVER"<br>    <br>End Sub</p>
<p>Public Sub SetShapeZConstant(pGeom As IGeometry, z As Double)<br>  Dim pZAware As IZAware<br>  Set pZAware = pGeom<br>  pZAware.ZAware = True<br>  <br>  If (pGeom.GeometryType = esriGeometryPoint) Then<br>    Dim pT As IPoint<br>    Set pT = pGeom<br>    pT.z = z<br>  Else<br>    Dim pZ As IZ<br>    Set pZ = pGeom<br>    pZ.SetConstantZ z<br>  End If<br>End Sub</p>

正需要！！！燃眉之急阿<img src="images/post/smile/dvbbs/em03.gif" />

<img src="images/post/smile/dvbbs/em01.gif" />

非常感谢

DING