如何用VBA连接相邻的长折线？
已经醒了大约30个小时，我的项目越来越慢。我想我很快就会“睡觉”。我希望今天晚上醒来，找到以下问题的解决方案。在一层上是一堆开放的LW折线。从视觉上看，它们形成了一个封闭的轮廓，因为它们的端点都相邻。该图层上没有其他东西，只有这个LW多段线的集合。
我需要知道这个轮廓的封闭区域。
一个普通的Autocad用户会选择修改-加入，选择一条多段线，然后用栅栏选择其他的，或者冻结所有其他图层，然后选择剩下的所有（Ctrl-A）。瞧，所有的多段线现在都是一条巨大的封闭多段线，其中的区域可以在属性窗口中找到。
我可以通过在VBA中使用send命令来模仿这样一个普通的Autocad用户，但老实说，我讨厌这样，它们会在你最意想不到的时候咬你。我也可以使用算术。形状是一堆参数化建模例程的副产品，这是我之前完成的程序的一部分，所以我也许可以通过“回溯”这些例程来收集必要的信息。
但我相信你们中的一个人有一个使用干净VB（A）的简单解决方案，所以当我醒来时，我会有一些期待，并且能够在本周末的某个时候完成d***项目，至少是具有挑战性的部分。
现在是上午10点30分，我又开始看到眼角的那些小动作。睡觉时间！在声音开始之前......：丑陋：
**** Hidden Message ***** 不错的功能Jürg （哎呀，我在完成之前就发布了我的回复！这是最终版本。）
我总是羡慕那些只需阅读音符就能“听到”音乐的音乐家。同样使用VBA，我可能永远不会达到那种水平的监视。所以我花了一些时间来“听到你的代码的音乐”。用我简单的话来说，我发现它的作用是：
检查您呈现的两条折线是否可以连接。如果是这样，请将第二个的顶点等添加到第一个，删除第二个并报告“任务完成！我加入了两个折线”。
所以，现在，所需要的只是一个嵌入例程：
创建一个要研究的折线选择集
-比较/连接集合中的第一个与所有其他的（使用您的函数）
-在所有比较之后，如果可能，与第一个连接，刷新选择集
-执行新运行，另一个（或使用递归或嵌套循环），直到只剩下一个折线或无法进行进一步的连接
然后关闭此折线并获取我需要的区域值。（除此之外，这幅画已经被清理了一些，但是无知的观众看不到区别。）
谢谢尤尔格！与此同时，我为我的问题找到了一个更简单的解决方案（今天早上我昏昏欲睡，看不见它），但我认为许多其他读者很可能会利用你的杰作！ 像这样的东西应该可以工作
Sub JoininJoininJoinin()
'Get them plines joinin'
'This song is quite anoyin'
'raw code
Dim objSelSet As AcadSelectionSet
Dim objSelSets As AcadSelectionSets
Dim intGroup(0 To 1) As Integer
Dim varData(0 To 1) As Variant
Dim intcnt As Integer
Set objSelSets = ThisDrawing.SelectionSets
For Each objSelSet In objSelSets
If objSelSet.Name = "PolyJoin" Then
objSelSets.Item(objSelSet.Name).Delete
Exit For
End If
Next objSelSet
intGroup(0) = 0: varData(0) = "LWPolyline": intGroup(1) = 8: varData(1) = "LayerName"
Set objSelSet = objSelSets.Add("PolyJoin")
objSelSet.Select acSelectionSetAll, , , intGroup, varData
For intcnt = 1 To objSelSet.Count - 1
MeJoinPline objSelSet.Item(0), objSelSet.Item(intcnt), 0.01
Next intcnt
End Sub
仔细想想，只有当它们在选择集中都按顺序排列时，它才起作用。如果它们不按顺序排列，很可能，它不会连接所有的东西。您可以将选择集分解为一个函数，填充它，运行连接函数，重新填充选择集，然后循环，直到选择集计数= 1。不过要打个勾，因为如果他们中的任何一个不在你的模糊因素之内，不能加入，你就会永远循环下去。 我已经为此工作了2年，它的99.5%，其中一些3D有点棘手。我为cnc画了很多，所以我不想要额外的顶点或线。这应该删除坏蛋。至于应该加入什么，你必须做出决定。我不知道我是否应该先把所有的线都做成多边形。我很确定我可以在这里消除一些步骤，但是越来越难看到树木的觅食。
Option Explicit
Declare Function GetCursor Lib "user32" () As Long
Public Declare Function GetAsyncKeyState Lib "user32" _
(ByVal vKey As Long) As Integer
Public Declare Sub CopyMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(dest As Any, source As Any, ByVal Length As Long) 'AlmostEqual
Private DeleteCol As Collection
Private StartEndCol As Collection
Private SlopeCol As Collection
Private CoordList As Collection
Private Const PolyClosedFudge As Double = 0.005
'If the first coordinate and last coordinate are within this distance
'The poly will be closed.
Const Pi As Double = 3.14159265358979
Public Property Get CurrentSpace() As AcadBlock
If ThisDrawing.GetVariable("CVPORT") = 1 Then
Set CurrentSpace = ThisDrawing.PaperSpace
Else
Set CurrentSpace = ThisDrawing.ModelSpace
End If
End Property
'Aims
'1) To select a group of lines,arcs and polys
'and create clean polys w/ no double ups
'or double points.
'2) Delete unnecessary geometry
'Some will want to add a layer control here.
'3) Note 2d and 3dpolys are not included
'4) I have used line formulas rather than polar angles
'hoping that it will be faster.
Sub VBAPLJoin()
'On Error GoTo Err_Control
Dim oLine As AcadLine
Dim LineCol As New Collection
Dim oPline As AcadLWPolyline
Dim CoordsCt As Integer
Dim oArc As AcadArc
Dim oSSets As AcadSelectionSets
Dim ss As AcadSelectionSet
Dim FilterType(6) As Integer
Dim FilterData(6) As Variant
Dim i As Integer, j As Integer, k As Integer
Dim intNotParallel As Integer
Dim PtsCount As Integer, Count As Integer
Dim StartPt As Variant, EndPt As Variant
Dim StartP(2) As Double, EndP(2) As Double
Dim Pt As Variant
Dim pts() As Double
Dim SE(4) As Variant
Dim obj(0) As AcadEntity
Dim M As Double, OrigY As Double
Dim UcsNormal As Variant, N As Variant
Dim blnRemove As Boolean
Dim dblElev As Double
Dim strlayer As String
Dim util As AcadUtility
PtsCount = 1
Set util = ThisDrawing.Utility
Set StartEndCol = New Collection
'Stage 1Create the selectionset
Set oSSets = ThisDrawing.SelectionSets
For Each ss In oSSets
If ss.Name = "SS" Then
ss.Delete
Exit For
End If
Next
Set ss = oSSets.Add("SS")
FilterType(0) = 0: FilterData(0) = "Line,Arc,LWPolyline"
FilterType(1) = -4: FilterData(1) = ""
FilterType(6) = -4: FilterData(6) = "NOT>"
Do ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
ss.SelectOnScreen FilterType:=FilterType, FilterData:=FilterData
Loop Until GetCursor = 0
If ss.Count > 500 Then
MsgBox "You have selected " & ss.Count & " objects. Please select less :"
Exit Sub
End If
If ss.Count = 0 Then
Set ss = Nothing
''''''''''''MsgBox "Nothing selected."
Exit Sub
End If
If ss.Count = 1 Then
If TypeOf ss(0) Is AcadLWPolyline Then
Set oPline = ss(0)
If UBound(oPline.Coordinates) = 3 Then
Exit Sub
End If
End If
End If
UcsNormal = CurrentUcsNormal
'We're using the SS set index to keep track of the objects
'So first pass is just to clean up the set
'From then on the order wont change
'Stage 2- delete zero length ents, remove non applicable ents
For i = ss.Count - 1 To 0 Step -1
If TypeOf ss(i) Is AcadLine Then
Set oLine = ss(i)
If oLine.Length0 Then
CheckLines LineCol 'Sub checks for equal, overlapping lines
End If
If ss.Count = 0 Then 'items may have been removed
Exit Sub
End If
If intNotParallel = 1 Then
MsgBox intNotParallel & " object was not parallel to the current UCS."
ElseIf intNotParallel > 1 Then
MsgBox intNotParallel & " objects were not parallel to the current UCS."
End If
'Stage 5
'This function sorts the start and end points into order
If StartEndCol.Count > 1 Then
SortPts
End If
Dim blnClosed As Boolean, blnNewLine As Boolean
Dim BulgeCol() As Double, PolyBulgeCol() As Double
Dim MPt(2) As Double, Seg As Double, Ht As Double
Dim sPt, ePt
ReDim pts(1)
AddNewLine:
Count = StartEndCol.Count
j = 0
If Count > 1 Then
For i = 1 To Count
If StartEndCol(i)(2) = "NewLine" Then
j = i - 1
Exit For
End If
Next
If j = 0 Then j = Count
If EqualPts(StartEndCol(1)(0), StartEndCol(j)(1)) Then
blnClosed = True
End If
End If
N = ss(StartEndCol(1)(2)).Normal
dblElev = ElevationFromPt(StartEndCol(1)(0), N) '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
strlayer = ss(StartEndCol(1)(2)).Layer
'Stage 6
'Draw a pline for each set of continuous points
'NewLine signifies there are no more points to add
'to the last poly so a new poly is reqd.
sPt = StartEndCol(1)(0)
sPt = util.TranslateCoordinates(sPt, acWorld, acOCS, 1, N)
pts(0) = sPt(0)
pts(1) = sPt(1)
PtsCount = 1
For i = 1 To StartEndCol.Count
If StartEndCol(i)(2) = "NewLine" Then
StartEndCol.Remove i
blnNewLine = True
Exit For
End If
If TypeOf ss(StartEndCol(i)(2)) Is AcadArc Then
Set oArc = ss(StartEndCol(i)(2))
ePt = StartEndCol(i)(1)
ePt = util.TranslateCoordinates(ePt, acWorld, acOCS, 1, N)
ReDim Preserve pts(PtsCount + 2)
pts(PtsCount + 1) = ePt(0)
pts(PtsCount + 2) = ePt(1)
'Now get the bulge
sPt = ToUcs(oArc.Startpoint): ePt = ToUcs(oArc.Endpoint)
Dim CPt As Variant
CPt = ToUcs(oArc.Center)
MPt(0) = sPt(0) + ((ePt(0) - sPt(0)) / 2)
MPt(1) = sPt(1) + ((ePt(1) - sPt(1)) / 2)
MPt(2) = sPt(2)
Seg = (Length(sPt, ePt)) / 2
If oArc.TotalAngle > Pi Then
Ht = (2 * oArc.radius) - (oArc.radius - Length(CPt, MPt))
Else
Ht = oArc.radius - Length(CPt, MPt)
End If
ReDim Preserve BulgeCol((PtsCount - 1) / 2)
If EqualPts(oArc.Startpoint, StartEndCol(i)(0)) Then
BulgeCol((PtsCount - 1) / 2) = Ht / Seg 'Bulge
Else
BulgeCol((PtsCount - 1) / 2) = -Ht / Seg
End If
PtsCount = PtsCount + 2
StartEndCol.Remove i
i = i - 1
GoTo Skip3
End If
If TypeOf ss(StartEndCol(i)(2)) Is AcadLine Then
PlineLine:
ePt = StartEndCol(i)(1)
ePt = util.TranslateCoordinates(ePt, acWorld, acOCS, 1, N)
'addpt EPt, , 2
ReDim Preserve pts(PtsCount + 2)
pts(PtsCount + 1) = ePt(0)
pts(PtsCount + 2) = ePt(1)
ReDim Preserve BulgeCol((PtsCount - 1) / 2)
BulgeCol((PtsCount - 1) / 2) = 0
PtsCount = PtsCount + 2
StartEndCol.Remove i
i = i - 1
GoTo Skip3
End If
If TypeOf ss(StartEndCol(i)(2)) Is AcadLWPolyline Then
Set oPline = ss(StartEndCol(i)(2))
CoordsCt = (UBound(oPline.Coordinates) - 1) / 2
If CoordsCt = 1 Then
If oPline.GetBulge(0) = 0 Then
GoTo PlineLine
End If
End If
Dim Coord, coords()
ReDim coords(CoordsCt)
ReDim PolyBulgeCol(CoordsCt - 1)
For j = 0 To 1
StartPt(j) = oPline.Coordinates(j)
Next j
StartPt(2) = oPline.Elevation
Pt = util.TranslateCoordinates(StartPt, acOCS, acWorld, 1, oPline.Normal)
If Not EqualPts(Pt, StartEndCol(i)(0)) Then 'swap''''''''''''''''''
k = 0
For j = CoordsCt To 0 Step -1
coords(k) = oPline.Coordinate(j)
k = k + 1
Next
k = 0
For j = CoordsCt - 1 To 0 Step -1
PolyBulgeCol(k) = -oPline.GetBulge(j)
k = k + 1
Next
Else
For j = 0 To CoordsCt
coords(j) = oPline.Coordinate(j)
Next
For j = 0 To CoordsCt - 1
PolyBulgeCol(j) = oPline.GetBulge(j)
Next
End If
ReDim Preserve pts(PtsCount + (CoordsCt * 2))
For j = 1 To CoordsCt 'We already have the first pair
pts(PtsCount + 1) = coords(j)(0)
pts(PtsCount + 2) = coords(j)(1)
ReDim Preserve BulgeCol((PtsCount - 1) / 2)
BulgeCol((PtsCount - 1) / 2) = PolyBulgeCol(j - 1)
PtsCount = PtsCount + 2
Next
StartEndCol.Remove i
i = i - 1
GoTo Skip3
End If
Skip3:
If StartEndCol.Count = 0 Then
Exit For
End If
Next i
If blnClosed Then
ReDim Preserve pts(PtsCount - 2)
End If
Set oPline = ThisDrawing.ModelSpace.AddLightWeightPolyline(pts)
oPline.Elevation = dblElev
'oPline.Normal = N ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'oPline.Color = acMagenta
oPline.Layer = strlayer
For i = 0 To UBound(BulgeCol)
oPline.SetBulge i, BulgeCol(i)
Next
If blnClosed Then
oPline.Closed = True
Else
PolyVertexCheck oPline ''''''''''''''''''''''''''''''''''
End If
If blnNewLine Then
blnNewLine = False
blnClosed = False
If StartEndCol.Count > 0 Then
GoTo AddNewLine
End If
End If
ss.Erase 'Delete the selection set leaving us w/ nice new polys
ss.Delete
Exit_Here:
Exit Sub
Err_Control:
Select Case Err.Number
'Add your Case selections here
Case Else
MsgBox Err.Description
Err.Clear
Resume Exit_Here
End Select
End Sub
一些函数
Function GetSlope(DeltaX, DeltaY, StartPt As Variant, _
M As Double, OrigY As Double) As Integer
DeltaX = CDbl(DeltaX)
DeltaY = CDbl(DeltaY)
If Rd(DeltaY, 0) Then 'Line is horizontal
M = 0
OrigY = StartPt(1)
GetSlope = 0
ElseIf Rd(DeltaX, 0) Then'Line is vertical
M = StartPt(0)
OrigY = 0
GetSlope = 1
Else
M = DeltaY / DeltaX
OrigY = StartPt(1) - (M * StartPt(0))
GetSlope = 2
End If
End Function
Private Function SortPts()
Dim A As Variant, b As Variant
Dim StartPt As Variant, EndPt As Variant
Dim NextStartPt As Variant, NextEndPt As Variant
Dim NewStartEndCol As New Collection
Dim blnRemoved As Boolean
Dim intBefore As Integer
Dim i As Integer
intBefore = 1
A = StartEndCol(1)
StartPt = A(0): EndPt = A(1)
NewStartEndCol.Add A
StartEndCol.Remove 1
Do While StartEndCol.Count > 0
Removed:
blnRemoved = False
For i = StartEndCol.Count To 1 Step -1
NextStartPt = StartEndCol(i)(0)
NextEndPt = StartEndCol(i)(1)
If EqualPts(StartPt, NextStartPt) Then
StartPt = NextEndPt
A = StartEndCol(i)
'swap start and end points
A(0) = NextEndPt
A(1) = NextStartPt
NewStartEndCol.Add A, , intBefore
blnRemoved = True
GoTo skip
End If
If EqualPts(StartPt, NextEndPt) Then
StartPt = NextStartPt
A = StartEndCol(i)
NewStartEndCol.Add A, , intBefore
blnRemoved = True
GoTo skip
End If
If EqualPts(EndPt, NextStartPt) Then
EndPt = NextEndPt
A = StartEndCol(i)
NewStartEndCol.Add A
blnRemoved = True
GoTo skip
End If
If EqualPts(EndPt, NextEndPt) Then
EndPt = NextStartPt
A = StartEndCol(i)
'swap start and end points
A(0) = NextEndPt
A(1) = NextStartPt
NewStartEndCol.Add A
blnRemoved = True
GoTo skip
End If
skip:
If blnRemoved Then
StartEndCol.Remove i
GoTo Removed
End If
Next
If blnRemoved = False Then
If StartEndCol.Count > 0 Then
A(2) = "NewLine"
NewStartEndCol.Add A
A = StartEndCol(1)
StartPt = A(0): EndPt = A(1)
NewStartEndCol.Add A
intBefore = NewStartEndCol.Count
StartEndCol.Remove 1
End If
End If
Loop
For i = 1 To NewStartEndCol.Count
StartEndCol.Add NewStartEndCol(i)
Next
End Function
'Rules used
'1)identical-
' delete one
'2)line within line-and no arms off the smaller-delete smaller
'if within has arm and the larger doesn't-remove the larger
'intWithin 1=start equal,2=end equal,3=neither
'3)Overlapping
'if no arms off the inside pts then delete both, add one long line
'intWithin=4
Private Sub CheckLines(LineCol As Collection)
Dim oLine As AcadLine
Dim SiAs Variant, SjAs Variant, varSEAs Variant
Dim blnSti As Boolean, blnStj As Boolean
Dim blnEndi As Boolean, blnEndj As Boolean
Dim Starti As Variant, Endi As Variant
Dim Startj As Variant, Endj As Variant
Dim i As Integer, j As Integer, k As Integer
Dim intWithin As Integer '1=start equal,2=end equal,3=neither
Dim blnRemoved As Boolean
Dim intVertical As Integer
For i = LineCol.Count To 1 Step -1 'allows removal from set
Si = LineCol(i)
Starti = Si(0): Endi = Si(1)
'now do the expensive point checks we will need to
'check if a line has an arm coming off it
'we only want to do this once
blnSti = PtCheck(Starti, i)
blnEndi = PtCheck(Endi, i)
For j = LineCol.Count To 1 Step -1
blnRemoved = False
If Not j = i Then
If Rd(LineCol(j)(4), LineCol(i)(4)) Then 'Check origY values
If Rd(LineCol(j)(3), LineCol(i)(3)) Then'Check slope values
'Check z values''''''''''''''''''''''''''''''''
Sj = LineCol(j)
Startj = Sj(0): Endj = Sj(1)
'now we dont have to factor in Line direction
'Make i the most left or the lowest
If Startj(0)Endi(0) Or Startj(1) > Endi(1) Then
GoTo skip 'Get it the next time
End If
'Check for identical
If Rd(Startj(0), Starti(0)) And Rd(Endj(0), Endi(0)) Then 'Could be vertical
If Rd(Startj(1), Starti(1)) Then
If Rd(Endj(1), Endi(1)) Then 'identical
DeleteIt LineCol, j
blnRemoved = True
'i = i - 1
GoTo skip
End If
End If
End If
intWithin = 0
intVertical = 0
'Check for within or overlapping
'Do the verticals first
If Rd(Startj(0), Starti(0)) And Rd(Endj(0), Endi(0)) Then'vertical now
intVertical = 1
If Rd(Startj(1), Starti(1)) Then
intWithin = 1
End If
If Startj(1) > Starti(1) Then
If Endj(1)i Then ''''''''''''''''
j = j - 1
End If
DeleteIt LineCol, j
LineCol.Add Si
StartEndCol.Add Si
'i = i - 1
GoTo skip
End If
End If
End If
End If
GoTo BranchControl
End If
'Now horiz. lines and the rest
If Rd(Startj(0), Starti(0)) Then
intWithin = 1
GoTo BranchControl
End If
If Startj(0) > Starti(0) Then
If Endj(0)i Then
j = j - 1
End If
DeleteIt LineCol, j
LineCol.Add Si
StartEndCol.Add Si
'i = i - 1
GoTo skip
End If
End If
End If
End If
If intWithin = 0 Then GoTo skip
BranchControl:
'now do the expensive point checks we will need to
'check if a line has an arm coming off it
'we only want to do this once
blnStj = PtCheck(Startj, j)
blnEndj = PtCheck(Endj, j)
If intWithin = 4 Then 'overlapping
If Not blnStj And Not blnEndi Then 'make one line
Si = LineCol(i)
Si(1) = Endj
DeleteIt LineCol, i
blnRemoved = True
If j > i Then ''''''''''''''''
j = j - 1
End If
DeleteIt LineCol, j
LineCol.Add Si
StartEndCol.Add Si
'i = i - 1
GoTo skip
End If
End If
If intWithin = 1 Then
If Endj(intVertical)i Then
j = j - 1
End If
If i > j Then
i = i - 1
End If
End If
Next j
Next i
End Sub
Private Sub DeleteIt(COL As Collection, i As Integer)
'Add layermanagement here if you need it.
Dim k As Integer
For k = 1 To StartEndCol.Count
If StartEndCol(k)(2) = COL(i)(2) Then
StartEndCol.Remove k
Exit For
End If
Next
COL.Remove i
End Sub
Function SortStartEnd(StartPt, EndPt)
Dim varPt As Variant
If EndPt(0) - StartPt(0) > 0.00000001 Then
'If StartPt(0)EndPt(1) Then
varPt = StartPt
StartPt = EndPt
EndPt = varPt
Else
Exit Function
End If
Else
varPt = StartPt
StartPt = EndPt
EndPt = varPt
End If
End If
End Function
Function CurrentUcsNormal() As Variant
Dim UcsX, UcsY, UcsZ(2) As Double
UcsX = ThisDrawing.GetVariable("Ucsxdir")
UcsY = ThisDrawing.GetVariable("Ucsydir")
'get CrossProduct
UcsZ(0) = UcsX(1) * UcsY(2) - UcsX(2) * UcsY(1)
UcsZ(1) = UcsX(2) * UcsY(0) - UcsX(0) * UcsY(2)
UcsZ(2) = UcsX(0) * UcsY(1) - UcsX(1) * UcsY(0)
CurrentUcsNormal = UcsZ
'Debug.Print UcsZ(0), UcsZ(1), UcsZ(2)
End Function
Function ToUcs(Pt As Variant) As Variant
ToUcs = ThisDrawing.Utility.TranslateCoordinates(Pt, acWorld, acUCS, False)
End Function
Function ToWcs(Pt As Variant) As Variant
ToWcs = ThisDrawing.Utility.TranslateCoordinates(Pt, acUCS, acWorld, False)
End Function
Function Rd(num1 As Variant, num2 As Variant) As Boolean
Dim dRet As Double
dRet = num1 - num2
If Abs(dRet)2 Or i0 Then
Stx = Startpoint(0): Sty = Startpoint(1)
Enx = Endpoint(0): Eny = Endpoint(1)
dX = Stx - Enx
dY = Sty - Eny
If i = 1 Then
Length = Sqr(dX * dX + dY * dY)
Else
Stz = Startpoint(2): Enz = Endpoint(2)
dZ = Stz - Enz
Length = Sqr((dX * dX) + (dY * dY) + (dZ * dZ))
End If
Else
Exit Function
End If
Else
Exit Function
End If
End Function
Function ElevationFromPt(Pt As Variant, varNormal As Variant) As Double
'Ax+ By + Cz + d = 0 formula for a plane where d=-oLWP.Elevation
'ElevationFromPt = Pt(0) * UcsNormal(0) + Pt(1) * UcsNormal(1) + Pt(2) * UcsNormal(2)
ElevationFromPt = (Pt(0) * varNormal(0)) + (Pt(1) * varNormal(1)) + (Pt(2) * varNormal(2))
End Function
这个是棘手的
Function PolyVertexCheck(oPline As AcadLWPolyline, Optional j As Integer = -1) As Boolean
'Checks for duplicate verticies
'Should be closed.
'Some Double backs
Dim cCount As Integer
Dim Dist As Double
Dim NewCoordList As New Collection
Dim i As Integer, k As Integer
Dim Coord As Variant, PrevCoord As Variant, coord2 As Variant
Dim Coord3 As Variant, Coord4 As Variant
Dim SlopeCol As New Collection
Dim BulgeCol As New Collection
Dim DeltaX As Double, DeltaY As Double
Dim StartPt As Variant
Dim M As Double, OrigY As Double
Dim Slopes(3) As Double
Dim intXY As Integer
Dim Rem1 As Integer, Rem2 As Integer
Dim intSlope As Integer
Dim obj(0) As AcadEntity
Dim ss As AcadSelectionSet
Dim blnBeginning As Boolean
Dim blnRemoved As Boolean
cCount = (UBound(oPline.Coordinates) - 1) / 2
NewCoordList.Add (0)
For i = 1 To cCount
Coord = oPline.Coordinate(i): PrevCoord = oPline.Coordinate(i - 1)
'Here we check for two equal verticies. Dont add them if they are equal.
If Rd(Coord(0), PrevCoord(0)) And Rd(Coord(1), PrevCoord(1)) Then GoTo skip
DeltaX = Coord(0) - PrevCoord(0): DeltaY = Coord(1) - PrevCoord(1)
Slopes(2) = GetSlope(DeltaX, DeltaY, PrevCoord, M, OrigY)
Slopes(0) = M: Slopes(1) = OrigY
Slopes(3) = oPline.GetBulge(i - 1)
SlopeCol.Add Slopes
k = i
NewCoordList.Add (k)
skip:
Next
cCount = NewCoordList.Count
Debug.Print cCount
If cCount = 1 Then 'zero length pline
Set ss = ThisDrawing.SelectionSets("SS")
If j > -1 Then
Set obj(0) = ss(j)
ss.RemoveItems obj
End If
oPline.Delete
PolyVertexCheck = False
Exit Function '''''
End If
BeginCheck:
If cCount > 2 Then
If SlopeCol.Count = 2 Then
'check for unneeded middle point in a straigth line
If SlopeCol(1)(3)0 Then GoTo Skip2
If SlopeCol(2)(3)0 Then GoTo Skip2
If Rd(SlopeCol(1)(0), SlopeCol(2)(0)) Then
If Rd(SlopeCol(1)(1), SlopeCol(2)(1)) Then
Coord = oPline.Coordinate(0)
coord2 = oPline.Coordinate(1)
Coord3 = oPline.Coordinate(2)
If EqualPts(Coord, Coord3) Then
NewCoordList.Remove cCount
GoTo Skip2
End If
intSlope = SlopeCol(1)(2)
If intSlope = 1 Then
intXY = 1'vertical
Else
intXY = 0
End If
If Coord(intXY) > coord2(intXY) Then
If coord2(intXY) > Coord3(intXY) Then
NewCoordList.Remove 2
Else
If Coord(intXY) > Coord3(intXY) Then
NewCoordList.Remove 3
Else
NewCoordList.Remove 1
End If
End If
Else
If Coord(intXY) > Coord3(intXY) Then
NewCoordList.Remove 1
Else
If Coord3(intXY) > coord2(intXY) Then
NewCoordList.Remove 2
Else
NewCoordList.Remove 3
End If
End If
End If
End If
End If
Else
For i = cCount To 3 Step -1
'check for unneeded middle point in a straigth line
If oPline.GetBulge(i - 1)0 Then GoTo Skipi
If oPline.GetBulge(i - 2)0 Then GoTo Skipi
If Rd(SlopeCol(i - 1)(0), SlopeCol(i - 2)(0)) Then
If Rd(SlopeCol(i - 1)(1), SlopeCol(i - 2)(1)) Then
Coord = oPline.Coordinate(NewCoordList(i))
coord2 = oPline.Coordinate(NewCoordList(i - 1))
Coord3 = oPline.Coordinate(NewCoordList(i - 2))
If Rd(Coord(0), coord2(0)) Then 'vertical
intXY = 1
Else
intXY = 0
End If
If i = cCount Then 'Double back at end
If Coord(intXY) > Coord3(intXY) Then
If Coord(intXY)coord2(intXY) Then
NewCoordList.Remove (i)
SlopeCol.Remove i - 1
blnRemoved = True
GoTo Skipi ''''''''''''''''''
End If
End If
End If
If i - 3 = 0 Then 'Double back at beginning
If Coord(intXY) > coord2(intXY) Then
If Coord(intXY) > Coord3(intXY) Then
If Coord3(intXY) > coord2(intXY) Then
NewCoordList.Remove (1)
SlopeCol.Remove 1
blnBeginning = True
blnRemoved = True
GoTo Skipi ''''''''''''''''''
End If
End If
Else
If Coord(intXY)coord2(intXY) Then
If coord2(intXY) > Coord3(intXY) Then
NewCoordList.Remove (i - 1)
SlopeCol.Remove i - 2
blnRemoved = True
GoTo Skipi ''''''''''''''''''
End If
Else
If coord2(intXY)2 Then
cCount = NewCoordList.Count
For i = cCount To 4 Step -1
If oPline.GetBulge(i - 1)0 Then GoTo Skip2i
If oPline.GetBulge(i - 2)0 Then GoTo Skip2i
If oPline.GetBulge(i - 3)0 Then GoTo Skip2i
If oPline.GetBulge(i - 4)0 Then GoTo Skip2i
'Not checking for arc double backs as they are so rare.
intSlope = SlopeCol(i - 1)(2)
If Not intSlope = SlopeCol(i - 2)(2) Then GoTo Skip2i
If Not intSlope = SlopeCol(i - 3)(2) Then GoTo Skip2i
If intSlope = 0 Then intXY = 0'horiz
If intSlope = 1 Then intXY = 1'vertical
If intSlope = 2 Then
intXY = 2 ''''''''''''''''''''''2-15
If Rd(SlopeCol(i - 1)(0), SlopeCol(i - 2)(0)) Then
If Rd(SlopeCol(i - 2)(0), SlopeCol(i - 3)(0)) Then
If Rd(SlopeCol(i - 1)(1), SlopeCol(i - 2)(1)) Then
If Rd(SlopeCol(i - 2)(1), SlopeCol(i - 3)(1)) Then
intXY = 0
'Else: GoTo Skip2i ''''''''''''''''''''''''''
End If
End If
End If
End If
End If
If intXY > 1 Then GoTo Skip2i
Coord = oPline.Coordinate(NewCoordList(i - 3))
coord2 = oPline.Coordinate(NewCoordList(i - 2))
Coord3 = oPline.Coordinate(NewCoordList(i - 1))
Coord4 = oPline.Coordinate(NewCoordList(i))
If Rd(Coord(0), coord2(0)) Then 'vertical
intXY = 1
Else
intXY = 0
End If
Rem1 = -1: Rem2 = -1
'code for double backs''''''''''''''''''''''''''''''
If Coord(intXY)Coord(intXY) Then
Rem1 = i - 1: Rem2 = i - 2
Else
Rem1 = i - 2: Rem2 = i - 3
End If
End If
Else
If Coord3(intXY) > Coord(intXY) Then
Rem1 = i: Rem2 = i - 1
Else
Rem1 = i: Rem2 = i - 3
End If
End If
Else
If coord2(intXY) > Coord4(intXY) Then
If Coord3(intXY) > coord2(intXY) Then
If Coord3(intXY)-1 Then
NewCoordList.Remove Rem1
SlopeCol.Remove Rem1 - 1
i = i - 1
End If
If Rem2 > -1 Then
NewCoordList.Remove Rem2
'i = i - 1
If Rem2 > 1 Then
SlopeCol.Remove Rem2 - 1
Else
SlopeCol.Remove Rem2
End If
End If
Skip2i:
Next i
End If
End If
End If
Skip2:
Dim NewPline As AcadLWPolyline
Dim Cwidth As Double
Dim blnNonConstantWidth As Boolean
On Error Resume Next
Cwidth = oPline.ConstantWidth
If Err.Description = "Invalid input" Then
blnNonConstantWidth = True
Err.Clear
End If
On Error GoTo 0
'check for should be closed
If oPline.Closed = False Then
Dim X1 As Double, Y1 As Double
Dim X2 As Double, Y2 As Double
Dim blnClosed As Boolean
X1 = oPline.Coordinate(NewCoordList(1))(0)
Y1 = oPline.Coordinate(NewCoordList(1))(1)
X2 = oPline.Coordinate(NewCoordList(NewCoordList.Count))(0)
Y2 = oPline.Coordinate(NewCoordList(NewCoordList.Count))(1)
If Fuzzed(X1, X2, PolyClosedFudge) Then
If Fuzzed(Y1, Y2, PolyClosedFudge) Then
NewCoordList.Remove (NewCoordList.Count)
blnClosed = True
End If
End If
End If
If Not NewCoordList.Count - 1 = (UBound(oPline.Coordinates) - 1) / 2 Then
Dim PtsCount As Integer
PtsCount = (NewCoordList.Count * 2) - 1
Dim pts() As Double
ReDim pts(PtsCount) As Double
cCount = NewCoordList.Count
For i = 1 To cCount
k = (i - 1) * 2
pts(k) = oPline.Coordinate(NewCoordList(i))(0)
pts(k + 1) = oPline.Coordinate(NewCoordList(i))(1)
Next
Set NewPline = CurrentSpace.AddLightWeightPolyline(pts)
If oPline.Closed = True Then
NewPline.Closed = True
End If
With NewPline
.Color = oPline.Color
.Elevation = oPline.Elevation
.Layer = oPline.Layer
.LineType = oPline.LineType
.LinetypeGeneration = oPline.LinetypeGeneration
.LineWeight = oPline.LineWeight
.Normal = oPline.Normal
.Thickness = oPline.Thickness
If Cwidth > 0 Then
.ConstantWidth = Cwidth
End If
On Error GoTo 0
End With
'For i = 1 To NewCoordList.Count
For i = 1 To SlopeCol.Count
k = i - 1
NewPline.SetBulge k, SlopeCol(i)(3)
If blnNonConstantWidth Then
Dim StartWidth As Double, endWidth As Double
oPline.GetWidth NewCoordList(i), StartWidth, endWidth
NewPline.SetWidth k, StartWidth, endWidth
End If
Next
If j = -1 Then
oPline.Delete
Set oPline = NewPline
Else
Set ss = ThisDrawing.SelectionSets("SS")
Set obj(0) = ss(j)
ss.RemoveItems obj
oPline.Delete
Set oPline = NewPline
If blnClosed = True Then
oPline.Closed = True
Else
Set obj(0) = oPline
ss.AddItems obj
End If
End If
oPline.Update
End If
PolyVertexCheck = True
End Function
哦，他们看起来太久了，每个人在到达这里之前都会睡着。 你有展示你的代码所做的例子的图像吗？
谢谢。
页:
[1]
2