yzhou_swnu
路人甲
路人甲
  • 注册日期2004-11-15
  • 发帖数4
  • QQ
  • 铜币119枚
  • 威望0点
  • 贡献值0点
  • 银元0个
阅读:2597回复:18

请教: 在mo中如何实现分割面的功能

楼主#
更多 发布于:2004-11-15 20:40
<P>在mo中如何实现分割面的功能, 小第多次实验后未果,望高手多多指教! </P>
<P>email:yzhou_swnu@163.com</P>
<P>qq:6624711</P>
喜欢0 评分0
lixaokui
路人甲
路人甲
  • 注册日期2003-12-25
  • 发帖数768
  • QQ28796446
  • 铜币27枚
  • 威望0点
  • 贡献值0点
  • 银元0个
1楼#
发布于:2004-11-16 09:03
你想要怎么个分割法呢?
西门吹血,有了鼓风机,就不用吹啦!
举报 回复(0) 喜欢(0)     评分
gis
gis
管理员
管理员
  • 注册日期2003-07-16
  • 发帖数15947
  • QQ554730525
  • 铜币25339枚
  • 威望15364点
  • 贡献值0点
  • 银元0个
  • GIS帝国居民
  • 帝国沙发管家
  • GIS帝国明星
  • GIS帝国铁杆
2楼#
发布于:2004-11-16 09:12
<P>下面几个贴都是一个分割多边形的类里的几个函数,发给你看看,实现了很不规则的多边形的分割</P><P>大概的操作就是绘制线或者多边形来分割一个现有的多边形</P><P>Option Explicit</P><P>' CONSTANTS
  Private Const moHorizontal = 0
  Private Const moVertical = 1</P><P>Public Function SplitPolyWithLine(ByVal poly As MapObjects2.Polygon, ByVal splitLine As MapObjects2.Line)</P><P>Dim ptsCross As New MapObjects2.Points  ' crosspoints 'twixt poly and splitline
Dim newPoly As New MapObjects2.Polygon  ' original poly with crosspoints added
Dim newLine As New MapObjects2.Line     ' original splitline with crosspoints added
Dim i As Integer</P><P>Dim strValid As String</P><P>Dim mpLine As New MapObjects2.Line        ' intersection of newLine and newPoly as multipart line
Dim strsInfo As New MapObjects2.Strings   ' strings collection holding topology info
Dim splitPoly As New MapObjects2.Polygon  ' multipart poly made of split pieces
Dim outColl As New VBA.Collection         ' two final polygons in collection</P><P>' Checks for Valid Poly and Line
strValid = CheckValidity(poly, splitLine)
If Not strValid = "valid" Then
  MsgBox strValid, vbOKOnly, "SplitPolyWithLine"
  Set SplitPolyWithLine = Nothing
  Exit Function
End If</P><P>
' Bring the poly and splitline in as locals to avoid affecting the originals...
For i = 0 To poly.Parts.Count - 1
  newPoly.Parts.Add poly.Parts(i)
Next i
newLine.Parts.Add splitLine.Parts(0)</P><P>' If the splitline crosses the poly, calculate the new pieces
Set ptsCross = poly.GetCrossings(splitLine)
If ptsCross.Count > 0 Then
  '
  ' Add the crossing points to each of the shapes
  Set newLine = AddVertices(ptsCross, newLine)
  Set newPoly = AddVertices(ptsCross, newPoly)
  '
  ' Get the intersection of the line and poly as a multipart line
  Set mpLine = newPoly.Intersect(newLine)
  '
  ' Populate a Strings collection with the topology information
  Set strsInfo = PopStrsInfo(newPoly, mpLine, ptsCross)
  '
  ' Use the topo info in the strings collection to build a new multipart polygon
  Set splitPoly = BuildSplitPoly(newPoly, mpLine, strsInfo)
  '
Else ' we'll just separate the original poly's parts based on the splitLine
  Set splitPoly = newPoly
End If</P><P>' Separate the parts of the splitPoly based on where
' the parts fall in relation to the split Line
Set outColl = SeparatePolys(splitPoly, newLine)</P><P>' Unload variables from memory
Set ptsCross = Nothing
Set newPoly = Nothing
Set newLine = Nothing
Set mpLine = Nothing
Set strsInfo = Nothing
Set splitPoly = Nothing</P><P>' Return a VBA.Collection that contains two polys
Set SplitPolyWithLine = outColl
Set outColl = Nothing</P><P>End Function</P>
举报 回复(0) 喜欢(0)     评分
gis
gis
管理员
管理员
  • 注册日期2003-07-16
  • 发帖数15947
  • QQ554730525
  • 铜币25339枚
  • 威望15364点
  • 贡献值0点
  • 银元0个
  • GIS帝国居民
  • 帝国沙发管家
  • GIS帝国明星
  • GIS帝国铁杆
3楼#
发布于:2004-11-16 09:13
<P>Private Function AddVertices(ptsToInsert As MapObjects2.Points, shp As Object)</P><P>Dim ptsShpPart As MapObjects2.Points  ' the points collection of the Shp's nth part
Dim ptToInsert As MapObjects2.Point   ' the point to be inserted in the shp's part
Dim i As Integer                      ' common counter / index variable
Dim j As Integer                      ' ditto
Dim k As Integer                      ' ditto
Dim dist As Double                    ' distance from ptToInsert to vertex
Dim shortdistSeg As Double            ' distance to nearest Segment in Shp
Dim shortDistPart As Double           ' distance to nearest Part in Shp
Dim closestSegIdx As Integer          ' index of first pt in nearest segment
Dim closestPartIdx As Integer         ' index of nearest part</P><P>' Loop through all the points to be inserted
For i = 0 To ptsToInsert.Count - 1
  Set ptToInsert = ptsToInsert(i)
  'Find the closest segment in all the shp's parts
  shortdistSeg = 99999999
  shortDistPart = 99999999
  For j = 0 To shp.Parts.Count - 1
    Set ptsShpPart = shp.Parts(j)
    For k = 1 To ptsShpPart.Count
      If k = ptsShpPart.Count Then
        If shp.shapeType = moShapeTypePolygon Then
          dist = ptToInsert.DistanceToSegment(ptsShpPart(k - 1), ptsShpPart(0))
        Else
          Exit For
        End If
      Else
        dist = ptToInsert.DistanceToSegment(ptsShpPart(k - 1), ptsShpPart(k))
      End If
      If dist < shortdistSeg Then
        If dist < shortDistPart Then
          shortDistPart = dist
          closestPartIdx = j
        End If
        shortdistSeg = dist
        closestSegIdx = k
      End If
    Next k
  Next j
  '
  ' Insert or add the point into the appropriate place on the appropriate part
  If closestSegIdx < shp.Parts(closestPartIdx).Count Then
    shp.Parts(closestPartIdx).Insert closestSegIdx, ptToInsert
  Else
    shp.Parts(closestPartIdx).Add ptToInsert
  End If
'  shortDistPart = 99999999
'  shortdistSeg = 99999999
Next i
  
' Unload variables
Set ptsShpPart = Nothing
Set ptToInsert = Nothing</P><P>' Return the updated shape
Set AddVertices = shp</P><P>End Function</P>
举报 回复(0) 喜欢(0)     评分
gis
gis
管理员
管理员
  • 注册日期2003-07-16
  • 发帖数15947
  • QQ554730525
  • 铜币25339枚
  • 威望15364点
  • 贡献值0点
  • 银元0个
  • GIS帝国居民
  • 帝国沙发管家
  • GIS帝国明星
  • GIS帝国铁杆
4楼#
发布于:2004-11-16 09:13
<P>Private Function AddVertices(ptsToInsert As MapObjects2.Points, shp As Object)</P><P>Dim ptsShpPart As MapObjects2.Points  ' the points collection of the Shp's nth part
Dim ptToInsert As MapObjects2.Point   ' the point to be inserted in the shp's part
Dim i As Integer                      ' common counter / index variable
Dim j As Integer                      ' ditto
Dim k As Integer                      ' ditto
Dim dist As Double                    ' distance from ptToInsert to vertex
Dim shortdistSeg As Double            ' distance to nearest Segment in Shp
Dim shortDistPart As Double           ' distance to nearest Part in Shp
Dim closestSegIdx As Integer          ' index of first pt in nearest segment
Dim closestPartIdx As Integer         ' index of nearest part</P><P>' Loop through all the points to be inserted
For i = 0 To ptsToInsert.Count - 1
  Set ptToInsert = ptsToInsert(i)
  'Find the closest segment in all the shp's parts
  shortdistSeg = 99999999
  shortDistPart = 99999999
  For j = 0 To shp.Parts.Count - 1
    Set ptsShpPart = shp.Parts(j)
    For k = 1 To ptsShpPart.Count
      If k = ptsShpPart.Count Then
        If shp.shapeType = moShapeTypePolygon Then
          dist = ptToInsert.DistanceToSegment(ptsShpPart(k - 1), ptsShpPart(0))
        Else
          Exit For
        End If
      Else
        dist = ptToInsert.DistanceToSegment(ptsShpPart(k - 1), ptsShpPart(k))
      End If
      If dist < shortdistSeg Then
        If dist < shortDistPart Then
          shortDistPart = dist
          closestPartIdx = j
        End If
        shortdistSeg = dist
        closestSegIdx = k
      End If
    Next k
  Next j
  '
  ' Insert or add the point into the appropriate place on the appropriate part
  If closestSegIdx < shp.Parts(closestPartIdx).Count Then
    shp.Parts(closestPartIdx).Insert closestSegIdx, ptToInsert
  Else
    shp.Parts(closestPartIdx).Add ptToInsert
  End If
'  shortDistPart = 99999999
'  shortdistSeg = 99999999
Next i
  
' Unload variables
Set ptsShpPart = Nothing
Set ptToInsert = Nothing</P><P>' Return the updated shape
Set AddVertices = shp</P><P>End Function</P><P>Private Function PopStrsInfo(ByVal poly As MapObjects2.Polygon, ByVal mpLine As MapObjects2.Line, crossPts As MapObjects2.Points)</P><P>  Dim strs As New MapObjects2.Strings   ' Strings collection to hold topology info
    strs.Unique = False</P><P>  Dim crossnum As Integer               ' crossing number (0 based)
  Dim pPart As New MapObjects2.Polygon  ' poly.Part(pPartIdx) as polygon
  Dim pPartIdx As Integer               ' index into poly.Parts
  Dim pPts As New MapObjects2.Points    ' points from pPart
  Dim pPtIdx As Integer                 ' index into pPts
  '
  Dim testLine As MapObjects2.Line      ' intersection of mpLine and pPart
  Dim lPartIdx As Integer               ' index into mpLine.Parts
  Dim lPartIdxHold As Integer           ' holder for later comparison...
  Dim lPts As MapObjects2.Points        ' points from mpLine.Parts(lPartIdx)
  Dim lPtIdx As Integer                 ' index into lPts
  Dim lPtIdxHold As Integer             ' holder for later comparison...
  Dim ePtIdxHold As Integer             ' idx of other endpt of lPts
  Dim lOtherEndPt As MapObjects2.Point  ' other endpoint of lPts
  '
  Dim shortdist As Double               ' shortest distance holder
  Dim dist As Double                    ' distance between two shapes</P><P>' The strs Strings collection is set up as clusters of seven elements.
'  One of these elements, puse, is not used.  The cluster looks like this:
'
'  Strs(n)  Element   N is the
'  ---------------------------------------------------
'  0        pprtN     index of the poly part involved in this crossing
'  1        ppntN     index of the point in poly.Parts(pprtN)
'  2        xnumN     number of this crossing (crossnum) (unique for all clusters)
'  3        lprtN     index of the part of mpLine involved in this crossing
'  4        lpntN     index of point in mpLine.Parts(lprtN)
'  5        leptN     index of other end of mpLine.Parts(lprtN)
'  6        puseN     not used
'-----------------------------------------------------</P><P>' Init crossnum to 0.  This will be the main reference into the
'  the Strings collection.  Crossnum is sequential and does not
'  reset to zero between parts
crossnum = 0
  
' Loop through all parts in the polygon
For pPartIdx = 0 To poly.Parts.Count - 1
  '
  ' Pull out the polygon part as a separate polygon
  pPart.Parts.Add poly.Parts(pPartIdx)
  '
  ' See if there are any crossings between poly part and mpLine
  Set testLine = pPart.Intersect(mpLine)
  If testLine Is Nothing Then
    ' No crossings for this part... move on to next part
    Set pPart = Nothing
    Set pPts = Nothing
    GoTo SkipThisPart
  End If
  '
  ' Loop through all points in the polygon part
  Set pPts = poly.Parts(pPartIdx)
  For pPtIdx = 0 To pPts.Count - 1
    '
    ' Check to see if pPts(pPtIdx) is a cross point
    If pPts(pPtIdx).GetCrossings(crossPts).Count > 0 Then
      ' Add crossing info to Strings collection
      strs.Add "pprt" ; str(pPartIdx)
      strs.Add "ppnt" ; str(pPtIdx)
      strs.Add "xnum" ; str(crossnum)
      crossnum = crossnum + 1
      '
      ' Loop through each Part in mpLine to find the part/point that matches pprt:ppnt
      shortdist = 99999999
      For lPartIdx = 0 To mpLine.Parts.Count - 1
        Set lPts = mpLine.Parts(lPartIdx)
        For lPtIdx = 0 To lPts.Count - 1
          dist = lPts(lPtIdx).DistanceTo(pPts(pPtIdx))
          If dist < shortdist Then
            shortdist = dist
            lPartIdxHold = lPartIdx
            lPtIdxHold = lPtIdx
          End If
        Next lPtIdx
        Set lPts = Nothing
      Next lPartIdx
      strs.Add "lprt" ; str(lPartIdxHold)
      strs.Add "lpnt" ; str(lPtIdxHold)
      '
      ' Loop through this poly part to find the ptIdx that the mpline part ends on
      If lPtIdxHold = 0 Then
        Set lOtherEndPt = mpLine.Parts(lPartIdxHold).Item(mpLine.Parts(lPartIdxHold).Count - 1)
      Else
        Set lOtherEndPt = mpLine.Parts(lPartIdxHold).Item(0)
      End If
      shortdist = 99999999
      For lPtIdx = 0 To pPts.Count - 1
        dist = pPts(lPtIdx).DistanceTo(lOtherEndPt)
        If dist < shortdist Then
          shortdist = dist
          ePtIdxHold = lPtIdx
        End If
      Next lPtIdx
      strs.Add "lept" ; str(ePtIdxHold)
      strs.Add "puse" ; str(0) ' number of uses of crossing... not used
    End If
  Next pPtIdx
  Set pPts = Nothing
SkipThisPart:
Next pPartIdx</P><P>' Unload variables
Set pPart = Nothing
Set pPts = Nothing
Set testLine = Nothing
Set lPts = Nothing
Set lOtherEndPt = Nothing</P><P>' Return the strings collection
Set PopStrsInfo = strs
Set strs = Nothing
End Function</P>
举报 回复(0) 喜欢(0)     评分
gis
gis
管理员
管理员
  • 注册日期2003-07-16
  • 发帖数15947
  • QQ554730525
  • 铜币25339枚
  • 威望15364点
  • 贡献值0点
  • 银元0个
  • GIS帝国居民
  • 帝国沙发管家
  • GIS帝国明星
  • GIS帝国铁杆
5楼#
发布于:2004-11-16 09:14
<P>Private Function BuildSplitPoly(poly As MapObjects2.Polygon, mpLine As MapObjects2.Line, strs As MapObjects2.Strings)</P><P>  Dim crossnum As Integer               ' crossing number
  Dim origCrossNum As Integer           ' first crossnum of a part
  Dim atCrossNum As Integer             ' current crossnum in a part
  Dim idx As Integer                    ' temporary placeholder
  Dim pPart As New MapObjects2.Polygon  ' poly.Parts(pPartIdx) as polygon
  Dim pPartIdx As Integer               ' index into poly.Parts
  Dim pPts As New MapObjects2.Points    ' points for poly.Parts(pPartIdx)
  Dim pPtIdx As Integer                 ' index into pPts
  Dim lPartIdx As Integer               ' index into mpLine.Parts
  Dim lPts As MapObjects2.Points        ' points for mpLine.Parts(lPartIdx)
  Dim lPtIdx As Integer                 ' index into lPts
  '
  Dim newPoly As New MapObjects2.Polygon    ' poly to hold split pieces as parts
  Dim newPartPts As New MapObjects2.Points  ' points coll for split part
  '
  Dim xNumStrsIdx As Integer            ' strs(n) that matches current crossnum
  Dim notIntoIt As Boolean              ' whether we're in the loop or not
  Dim x_uses As New MapObjects2.Strings ' to keep track of number of uses of each
  x_uses.Unique = False                 '    crossing, to avoid duplicating parts
  '
  '
  Dim currPtIdx As Integer       ' index of current pt, from strs for this crossnum
  Dim currPartIdx As Integer     ' index of current part, from strs for this crossnum
  '
  Dim x_usesIdx As Integer       ' index into x_uses Strings collection
  Dim notUsedUp As Boolean       ' whether a crossing has already been used twice
  '
  Dim hasCrossings As Boolean    ' whether poly.Part(pPartIdx) has any crossings</P><P>' Add any parts that didn't have any crossings directly to newPoly
For pPartIdx = 0 To poly.Parts.Count - 1
  hasCrossings = False
  For crossnum = 0 To (strs.Count / 7) - 1
    xNumStrsIdx = strs.Find("xnum" ; str(crossnum))
    If GetStrsVal(xNumStrsIdx - 2, strs) = pPartIdx Then
      hasCrossings = True
      Exit For
    End If
  Next crossnum
  If hasCrossings = False Then
    newPoly.Parts.Add poly.Parts(pPartIdx)
  End If
Next pPartIdx</P><P>' Loop through each crossing stored in strs
For crossnum = 0 To (strs.Count / 7) - 1
  atCrossNum = crossnum
  notIntoIt = True
  '
  ' Figure out if we've already used this crossing twice...
  ' if so, then don't build this part...
  x_usesIdx = Val(x_uses.Find("xnum" ; str(atCrossNum)))
  notUsedUp = True
  If x_usesIdx > -1 Then
    If Val(x_uses(x_usesIdx + 1)) >= 2 Then
      notUsedUp = False
    End If
  End If
  '
  ' Build the split part
  Do While (atCrossNum <> crossnum Or notIntoIt) And notUsedUp
    notIntoIt = False ' we're in the loop...
    '
    ' Increment the number of uses of this crossing
    Set x_uses = UpdateX_Uses(atCrossNum, x_uses)
    '
    ' Add points from this ptIdx to next ptIdx (next crossing)
    ' The first point will be left out, to be made up for by the last point of AddSLineSeg
    Set newPartPts = AddToNextPtIdx(poly, newPartPts, atCrossNum, strs)
    '
    ' Figure out what crossing we're at
    idx = atCrossNum ' temporary hold
    If atCrossNum + 1 <= (strs.Count / 7) - 1 Then ' avoid going past last crossing for this part
      If strs(((atCrossNum + 1) * 7) - 7) = strs(((atCrossNum + 2) * 7) - 7) Then
        atCrossNum = atCrossNum + 1
      End If
    End If
    If idx = atCrossNum Then ' Loop through strs to find first crossing in this part
      For idx = 0 To strs.Count - 1 Step 7 ' the pprt slots
        If strs(idx) = strs(((atCrossNum + 1) * 7) - 7) Then
          atCrossNum = GetStrsVal(idx + 2, strs)
          Exit For
        End If
      Next idx
    End If
    '
    ' Update x_uses for this crossing's use
    Set x_uses = UpdateX_Uses(atCrossNum, x_uses)
    '
    ' add points from sLine segment
    Set newPartPts = AddSLineSeg(mpLine, newPartPts, atCrossNum, strs)
    '
    ' find out what crossing we're at
    xNumStrsIdx = strs.Find("xnum" ; str(atCrossNum))
    currPtIdx = GetStrsVal(xNumStrsIdx + 3, strs)
    currPartIdx = GetStrsVal(xNumStrsIdx - 2, strs)
    For xNumStrsIdx = 2 To strs.Count Step 7
      If GetStrsVal(xNumStrsIdx - 2, strs) = currPartIdx And GetStrsVal(xNumStrsIdx - 1, strs) = currPtIdx Then
        Exit For
      End If
    Next xNumStrsIdx
    atCrossNum = GetStrsVal(xNumStrsIdx, strs)
  Loop
  '
  ' Add new part if it was made...
  If newPartPts.Count > 0 Then
    newPoly.Parts.Add newPartPts
  End If
  Set newPartPts = Nothing
Next crossnum
'
' Unload varables
Set pPart = Nothing
Set pPts = Nothing
Set lPts = Nothing
Set newPartPts = Nothing
Set x_uses = Nothing
'
' Return the newPoly
Set BuildSplitPoly = newPoly
Set newPoly = Nothing
End Function</P>
举报 回复(0) 喜欢(0)     评分
gis
gis
管理员
管理员
  • 注册日期2003-07-16
  • 发帖数15947
  • QQ554730525
  • 铜币25339枚
  • 威望15364点
  • 贡献值0点
  • 银元0个
  • GIS帝国居民
  • 帝国沙发管家
  • GIS帝国明星
  • GIS帝国铁杆
6楼#
发布于:2004-11-16 09:14
<P>Private Function AddToNextPtIdx(poly As MapObjects2.Polygon, pts As MapObjects2.Points, crossnum As Integer, strs As MapObjects2.Strings)</P><P>Dim xNumStrsIdx As Integer      ' Index of this crossing's num in strings collection
Dim thisPtIdx As Integer        ' current crossing's ppntN value from strs
Dim nextPtIdx As Integer        ' next crossing's ppntN value from strs
Dim i As Integer                ' generic index variable
Dim pPts As MapObjects2.Points  ' points collection from poly.Parts for this crossnum</P><P>' Get the Index in strs of this crossing's number
xNumStrsIdx = strs.Find("xnum" ; str(crossnum))
'
' Get the polygon part
Set pPts = poly.Parts(GetStrsVal(xNumStrsIdx - 2, strs))
'
' Get the point index for this crossing
thisPtIdx = GetStrsVal(xNumStrsIdx - 1, strs) ' ppnt
'
' Get the point index for the next crossing
nextPtIdx = -1
' MIGHT be at the end of the crossings list
If xNumStrsIdx + 5 < strs.Count Then
  ' nextPtIdx MIGHT be in another Part... need to make sure it's in this part!
  If GetStrsVal(xNumStrsIdx + 5, strs) = GetStrsVal(xNumStrsIdx - 2, strs) Then
    nextPtIdx = GetStrsVal(xNumStrsIdx + 6, strs) ' next ppnt
  End If
End If
If nextPtIdx = -1 Then ' Loop through strs to find first crossing in this part.
  For i = 0 To strs.Count - 1 Step 7
    If strs(i) = strs(xNumStrsIdx - 2) Then
      nextPtIdx = GetStrsVal(i + 1, strs)
      Exit For
    End If
  Next i
End If
'
' Add the points to the points collection
' Skip the first point - the last point we add will be the first point.
If nextPtIdx < thisPtIdx Then ' need to go past zero...
  For i = thisPtIdx + 1 To pPts.Count - 1
    pts.Add pPts(i)
  Next i
  For i = 0 To nextPtIdx
    pts.Add pPts(i)
  Next i
Else
  For i = thisPtIdx + 1 To nextPtIdx
    pts.Add pPts(i)
  Next i
End If
'
' Return the points collection with new points added
Set pPts = Nothing
Set AddToNextPtIdx = pts
End Function
</P>
举报 回复(0) 喜欢(0)     评分
gis
gis
管理员
管理员
  • 注册日期2003-07-16
  • 发帖数15947
  • QQ554730525
  • 铜币25339枚
  • 威望15364点
  • 贡献值0点
  • 银元0个
  • GIS帝国居民
  • 帝国沙发管家
  • GIS帝国明星
  • GIS帝国铁杆
7楼#
发布于:2004-11-16 09:14
Private Function GetStrsVal(idx As Integer, strs As MapObjects2.Strings)
' This function retrieves a value from the strs Strings collection,
' strips off the four leading characters, and returns an integer.
Dim str As String
str = strs(idx)
' Strip first four characters
str = Right(str, Len(str) - 4)
GetStrsVal = Val(str)
End Function
举报 回复(0) 喜欢(0)     评分
gis
gis
管理员
管理员
  • 注册日期2003-07-16
  • 发帖数15947
  • QQ554730525
  • 铜币25339枚
  • 威望15364点
  • 贡献值0点
  • 银元0个
  • GIS帝国居民
  • 帝国沙发管家
  • GIS帝国明星
  • GIS帝国铁杆
8楼#
发布于:2004-11-16 09:15
<P>Private Function AddSLineSeg(mpLine As MapObjects2.Line, pts As MapObjects2.Points, crossnum As Integer, strs As MapObjects2.Strings)</P><P>Dim xNumStrsIdx As Integer      ' Index of this crossing's num in strings collection
Dim startPtIdx As Integer       ' index of start point on mpLine segment
Dim i As Integer                ' generic index variable
Dim lPts As MapObjects2.Points  ' points collection from mpLine segment</P><P>' Get the Index in strs of this crossing's number
xNumStrsIdx = strs.Find("xnum" ; str(crossnum))
'
' Get the mpLine part we're interested in
Set lPts = mpLine.Parts(GetStrsVal(xNumStrsIdx + 1, strs)) ' lprtN
'
' Get the start point index for piece of mpLine
startPtIdx = GetStrsVal(xNumStrsIdx + 2, strs) ' lpntN
'
' Add the points to the points collection
' Skip the first point (it's already in there...)
If startPtIdx > 0 Then ' need to go in reverse
  For i = startPtIdx - 1 To 0 Step -1
    pts.Add lPts(i)
  Next i
Else
  For i = startPtIdx + 1 To lPts.Count - 1
    pts.Add lPts(i)
  Next i
End If
'
' Return the modified points collection
Set lPts = Nothing
Set AddSLineSeg = pts
End Function</P>
举报 回复(0) 喜欢(0)     评分
gis
gis
管理员
管理员
  • 注册日期2003-07-16
  • 发帖数15947
  • QQ554730525
  • 铜币25339枚
  • 威望15364点
  • 贡献值0点
  • 银元0个
  • GIS帝国居民
  • 帝国沙发管家
  • GIS帝国明星
  • GIS帝国铁杆
9楼#
发布于:2004-11-16 09:15
<P>Private Function SeparatePolys(sPoly As MapObjects2.Polygon, sline As MapObjects2.Line)</P><P>Dim spPartIdx As Integer              ' index into sPoly.Parts
Dim spPart As MapObjects2.Polygon     ' sPoly.Parts(spPartIdx)
Dim spCentroid As MapObjects2.Point   ' quasi-centroid of spPart</P><P>Dim slPts As MapObjects2.Points       ' points from sLine
Dim slPtIdx As Integer                ' index into slPts
Dim shortdist As Double               ' shortest distance holder
Dim dist As Double                    ' distance variable
Dim closePtIdx As Integer             ' index of closes point</P><P>Dim angle1 As Double      ' angle from spCentroid to slPts(closePtIdx)
Dim angle2 As Double      ' angle from spCentroid to slPts(closePtIdx + 1)
Dim partSide As Integer   ' side of sLine that spPart falls on</P><P>Dim outColl As New VBA.Collection             ' will hold two split polygons
Dim outLeftPoly As New MapObjects2.Polygon    ' poly on left side of sLine
Dim outRightPoly As New MapObjects2.Polygon   ' poly on right side of sLine</P><P>' Loop through the spoly parts
For spPartIdx = 0 To sPoly.Parts.Count - 1
  Set spPart = New MapObjects2.Polygon
  spPart.Parts.Add sPoly.Parts(spPartIdx)
  '
  ' Make sure the centroid is inside the part... if not, put it there!
  If Not spPart.IsPointIn(spPart.Centroid) Then
    Set spCentroid = CalcCentroid(spPart)
  Else
    Set spCentroid = spPart.Centroid
  End If
  '
  ' Find the closest seg on sLine to spPart's Centroid
  shortdist = 99999999
  Set slPts = sline.Parts(0)
  For slPtIdx = 0 To slPts.Count - 2 ' don't check last pt; we'll need closePtIdx + 1
    dist = spCentroid.DistanceToSegment(slPts(slPtIdx), slPts(slPtIdx + 1))
    If dist < shortdist Then
      shortdist = dist
      closePtIdx = slPtIdx
    End If
  Next slPtIdx
  '
  ' Determine which side of centroid the the line is on
  angle1 = FindAngle(spCentroid, slPts(closePtIdx))
  angle2 = FindAngle(spCentroid, slPts(closePtIdx + 1))
  If angle2 > angle1 Then
    If angle2 - angle1 < 180 Then
      partSide = moRightSide
    Else
      partSide = moLeftSide
    End If
  Else
    If angle1 - angle2 > 180 Then
      partSide = moRightSide
    Else
      partSide = moLeftSide
    End If
  End If
  '
  ' Add part to corresponding outPoly...
  If partSide = moRightSide Then
    outRightPoly.Parts.Add spPart.Parts(0)
  Else
    outLeftPoly.Parts.Add spPart.Parts(0)
  End If
Next spPartIdx
'
' Add Left and Right polys to collection
outColl.Add outLeftPoly
outColl.Add outRightPoly
'
' Unload variables
Set spPart = Nothing
Set spCentroid = Nothing
Set slPts = Nothing
Set outLeftPoly = Nothing
Set outRightPoly = Nothing
'
' Return collection
Set SeparatePolys = outColl
Set outColl = Nothing
End Function
</P>
举报 回复(0) 喜欢(0)     评分
上一页
游客

返回顶部