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


     

  • 相关阅读:
    Word转pdf
    jquery 中json数组的操作 增删改
    Js、Jquery定时执行(一次或者重复多次,取消重复)
    sql server 2008 (不允许保存更改,您所做的更改要求删除并重新创建以下表) 的解决办法
    C#中 ArrayList 的使用
    Jquery正则表达式公式
    C#判断字符串是否存在字母及字符串中字符的替换实例
    纳闷的EF异常:在提供程序连接上启动事务时出错
    C# WinForm获取当前路径汇总
    Entity Framwork 6 编译出错的问题(VS2012)
  • 原文地址:https://www.cnblogs.com/zhangjun1130/p/1771510.html
Copyright © 2011-2022 走看看