zoukankan      html  css  js  c++  java
  • arcmap vba 生成3维侧棱 以及 createfeature与createfeaturebuffer的区别

    Sub huaxian()
    Dim pMxDoc As IMxDocument
    Set pMxDoc = Application.Document

    Dim pMap As IMap
    Set pMap = pMxDoc.FocusMap

    Dim pActiveView As IActiveView
    Set pActiveView = pMxDoc.FocusMap

    Dim pFeatureClassOne As IFeatureClass
    Dim pFLayerOne As IFeatureLayer

    Dim pFeatureClassTwo As IFeatureClass
    Dim pFLayerTwo As IFeatureLayer

    Dim pFeatureClassNew As IFeatureClass
    Dim pFLayerNew As IFeatureLayer

    Set pFLayerOne = pMap.Layer(0)
    Set pFLayerTwo = pMap.Layer(1)
    Set pFLayerNew = pMap.Layer(2)

    Set pFeatureClassOne = pFLayerOne.FeatureClass
    Set pFeatureClassTwo = pFLayerTwo.FeatureClass
    Set pFeatureClassNew = pFLayerNew.FeatureClass

    Dim pFeatureCursorOne As IFeatureCursor
    Dim pFeatureCursorTwo As IFeatureCursor

    Set pFeatureCursorOne = pFeatureClassOne.Search(Nothing, True)
    Set pFeatureCursorTwo = pFeatureClassTwo.Search(Nothing, True)

    Dim pFeatureOne As IFeature
    Dim pFeatureTwo As IFeature

    Set pFeatureOne = pFeatureCursorOne.NextFeature
    Set pFeatureTwo = pFeatureCursorTwo.NextFeature


    Dim pPolygonOne As IPolygon
    Dim pPolygonTwo As IPolygon
    Dim pOnePoints As IPointCollection
    Dim pTwoPoints As IPointCollection
    Dim i As Integer

    Dim pFromPoint As IPoint
    Dim pToPoint As IPoint
    Dim pPolyline As IPolyline
    Dim polylinePoints As IPointCollection
    Dim pFeatureNew As IFeature

     'create a feature cursor and feature buffer interface
     Dim pFeatCur As IFeatureCursor
     Dim pFeatBuf As IFeatureBuffer
     
     'open the feature cursor and feature buffer
     Set pFeatCur = pFeatureClassNew.Insert(True)
     Set pFeatBuf = pFeatureClassNew.CreateFeatureBuffer

     Dim q As Long

     
    While Not pFeatureOne Is Nothing And Not pFeatureTwo Is Nothing
       Set pPolygonOne = pFeatureOne.Shape
       Set pPolygonTwo = pFeatureTwo.Shape
       Set pOnePoints = pPolygonOne
       Set pTwoPoints = pPolygonTwo
     
     For i = 0 To pOnePoints.PointCount - 1
      
       Set pFromPoint = pOnePoints.Point(i)
       Set pToPoint = pTwoPoints.Point(i)
       Set pPolyline = New Polyline
       Set polylinePoints = pPolyline
      
       polylinePoints.AddPoint pFromPoint
       polylinePoints.AddPoint pToPoint
      
       Set pFeatureNew = pFeatBuf
       Set pFeatureNew.Shape = pPolyline
     


       q = pFeatCur.InsertFeature(pFeatBuf)
      
       Next i
      
       Set pFeatureOne = pFeatureCursorOne.NextFeature
       Set pFeatureTwo = pFeatureCursorTwo.NextFeature
    Wend

    MsgBox "done!"
    End Sub

    ——————————————————————————————————————————————————————————————————————

    Sub huaxian()

    Dim pMxDoc As IMxDocument
    Set pMxDoc = Application.Document

    Dim pMap As IMap
    Set pMap = pMxDoc.FocusMap

    Dim pActiveView As IActiveView
    Set pActiveView = pMxDoc.FocusMap

    Dim pFeatureClassOne As IFeatureClass
    Dim pFLayerOne As IFeatureLayer

    Dim pFeatureClassTwo As IFeatureClass
    Dim pFLayerTwo As IFeatureLayer

    Dim pFeatureClassNew As IFeatureClass
    Dim pFLayerNew As IFeatureLayer

    Set pFLayerOne = pMap.Layer(0)
    Set pFLayerTwo = pMap.Layer(1)
    Set pFLayerNew = pMap.Layer(2)

    Set pFeatureClassOne = pFLayerOne.FeatureClass
    Set pFeatureClassTwo = pFLayerTwo.FeatureClass
    Set pFeatureClassNew = pFLayerNew.FeatureClass

    Dim pFeatureCursorOne As IFeatureCursor
    Dim pFeatureCursorTwo As IFeatureCursor

    Set pFeatureCursorOne = pFeatureClassOne.Search(Nothing, True)
    Set pFeatureCursorTwo = pFeatureClassTwo.Search(Nothing, True)

    Dim pFeatureOne As IFeature
    Dim pFeatureTwo As IFeature

    Set pFeatureOne = pFeatureCursorOne.NextFeature
    Set pFeatureTwo = pFeatureCursorTwo.NextFeature


    Dim pPolygonOne As IPolygon
    Dim pPolygonTwo As IPolygon
    Dim pOnePoints As IPointCollection
    Dim pTwoPoints As IPointCollection
    Dim i As Integer

    Dim pFromPoint As IPoint
    Dim pToPoint As IPoint
    Dim pPolyline As IPolyline
    Dim polylinePoints As IPointCollection
    Dim pFeatureNew As IFeature


     
    While Not pFeatureOne Is Nothing and Not pFeatureTwo Is Nothing
       Set pPolygonOne = pFeatureOne.Shape
       Set pPolygonTwo = pFeatureTwo.Shape
       Set pOnePoints = pPolygonOne
       Set pTwoPoints = pPolygonTwo
     
     For i = 0 To pOnePoints.PointCount - 1
      
       Set pFromPoint = pOnePoints.Point(i)
       Set pToPoint = pTwoPoints.Point(i)
       Set pPolyline = New Polyline
       Set polylinePoints = pPolyline
      
       polylinePoints.AddPoint pFromPoint
       polylinePoints.AddPoint pToPoint
      
       Set pFeatureNew = pFeatureClassNew.CreateFeature
       Set pFeatureNew.Shape = pPolyline
       pFeatureNew.Store
      
      
      
      
       Next i
      
       Set pFeatureOne = pFeatureCursorOne.NextFeature
       Set pFeatureTwo = pFeatureCursorTwo.NextFeature
    Wend

    MsgBox "done!"


    End Sub


     

  • 相关阅读:
    Git基本操作二
    Git基本操作一
    Mysql查询一
    接口的token验证
    Laravel模型的一些小技巧
    AOP编程思想实现全局异常处理
    5.4 RegExp类型
    5.4.1 RegExp实例属性
    5.4.2 RegExp实例方法
    5.4.3 RegExp构造函数属性
  • 原文地址:https://www.cnblogs.com/zhangjun1130/p/1771510.html
Copyright © 2011-2022 走看看