阅读:2878回复:18
请教: 在mo中如何实现分割面的功能
<P>在mo中如何实现分割面的功能, 小第多次实验后未果,望高手多多指教! </P>
<P>email:yzhou_swnu@163.com</P> <P>qq:6624711</P> |
|
1楼#
发布于:2004-11-16 09:03
你想要怎么个分割法呢?
|
|
|
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> |
|
|
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> |
|
|
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> |
|
|
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> |
|
|
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> |
|
|
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 |
|
|
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> |
|
|
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> |
|
|
上一页
下一页