在e处创建垂直线
大家好，我需要一个VBA代码在每个交点处创建线。直线的起点应为交点（通常为两条直线的交点），终点位于第三条直线的垂线处。
有数百个这样的点，所以我真的需要一个VBA代码。
谢谢和问候，
普里扬卡 这听起来是一个有趣的问题，尤其是当它需要3D兼容性时。不幸的是，我今天没有时间调查。
如果您可以发布一个示例文件，以更好地说明参数，我将看看明天或周末可以做些什么。 我附上了一个截图。手动操作很容易，但当你有数百个这样的点时就不行了。
请帮忙，
谢谢和问候，
普里扬卡
如果符号的大小和间距始终相同，那么“测量”命令可能会更好地工作？您可以插入较高的集合，从其起点拉伸直线以匹配两者之间的间距，然后插入第二个集合。
编辑：没关系，我看他们不是。 我假设您可以使用Lisp，在其中用户将选择第三条线（所有其他连接线垂直的线），然后用户将依次选择每个十字-Lisp每次添加垂直线。但这当然意味着用户将有选择所有十字架的繁琐任务。。。我只是不明白o e怎么能让ACAD认识到每一对线都是一个十字架，需要一条线。。。但是VBA也许可以完成这样的任务。。。 我假设从屏幕截图来看，我们严格处理的是2D几何。这很幸运，因为3D解决方案可能要复杂得多。
即使是平面几何，计算也非常多。交叉点的可能数量随着选择集的大小呈几何级数增加（Lee Mac提到的情况）。
下面的例程并不比标准的“暴力”方法好多少，因此任何可以将行数限制为仅与之相关的行数的方法都将有助于提高速度。
我已经完成了有限的测试和错误检查，因此请继续相应的操作。
Sub Inters2Perp() 'Main sub
Dim SOS As AcadSelectionSet
Dim objSS As AcadSelectionSet
Dim intCode(1) As Integer
Dim varData(1) As Variant
Dim objEnt As AcadEntity
Dim entBaseLine As AcadLine
Dim colPt As New Collection
Dim ent As AcadEntity
Dim varPt As Variant
With ThisDrawing
On Error Resume Next
.Utility.GetEntity ent, varPt, "Select the line to which perpendiculars will land: "
If Err <> 0 Or Not TypeOf ent Is AcadLine Then
.Utility.Prompt "Operation aborted!" & vbCr
Exit Sub
End If
On Error GoTo 0
Set entBaseLine = ent
For Each SOS In .SelectionSets
If SOS.Name = "MySS" Then
.SelectionSets("MySS").Delete
Exit For
End If
Next
intCode(0) = 0: varData(0) = "LINE"
intCode(1) = 8: varData(1) = "*" 'replace * with layer name of crossing lines
.SelectionSets.Add ("MySS")
Set objSS = ThisDrawing.SelectionSets("MySS")
objSS.SelectOnScreen intCode, varData
If objSS.Count < 1 Then
MsgBox "No lines and polylines selected!"
Exit Sub
End If
Set colPt = GenCollection(objSS)
GenLines colPt, entBaseLine
End With
End Sub
Function GenCollection(objSS As AcadSelectionSet) As Collection
Dim colPt As New Collection
Dim entPrimary As AcadLine
Dim entSecondary As AcadLine
Dim varPt As Variant
Dim i As Integer
Dim entObj(0) As AcadEntity
Do While objSS.Count > 1
Set entPrimary = objSS.Item(0)
For i = 1 To objSS.Count - 1
Set entSecondary = objSS.Item(i)
varPt = entPrimary.IntersectWith(entSecondary, acExtendNone)
If UBound(varPt) > 1 Then colPt.Add (varPt)
Next
Set entObj(0) = entPrimary
objSS.RemoveItems entObj
Loop
Set GenCollection = colPt
End Function
Private Sub GenLines(colPt As Collection, entBaseLine As AcadLine)
Dim dblAngle As Double
Dim varPt As Variant
Dim dblEndPt() As Double
Dim entLine As AcadLine
dblAngle = ThisDrawing.Utility.AngleFromXAxis(entBaseLine.StartPoint, entBaseLine.EndPoint) + 1.5707963268
For Each varPt In colPt
dblEndPt = ThisDrawing.Utility.PolarPoint(varPt, dblAngle, 1#)
Set entLine = ThisDrawing.ModelSpace.AddLine(varPt, dblEndPt)
On Error Resume Next
entLine.EndPoint = entLine.IntersectWith(entBaseLine, acExtendThisEntity)
If Err <> 0 Then entLine.Delete
Err.Clear
Next
End Sub 啊，所以这是可以做到的。。。我想这里面有很多“试错法”。。。
绝对地例行程序将检查每个选定行与其他选定行。
乍一看，我以为你的帖子在写例行公事的时候说“有很多”尝试和错误“，我想“他怎么知道的？” 为了便于讨论：
假设这是一个经常出现的任务，并且处理非常大的交叉线集（>10000），那么什么是好的优化方案呢？
我想为SS生成一个边界框，然后再细分为9或16。基于线条端点的过滤选择集可以分离出一口大小的块。这将避免许多交叉口测试失败，但可能会错过靠近边界的一些目标线。 是的，正如你所说，让例行程序比较两行的每一个组合是极其乏味的：
例如，如果一个有50行，如果程序执行两行的每个组合，即比较行L1和L2，但也比较L2和L1，则组合的数量如下：
~ 2450
但如果程序知道，如果它已经比较了L1和L2，而不是稍后比较L2和L1，则该数字将减少为：
~ 1225
如果我的数学是正确的（统计数据从来不是我的强项！）
但是，将其分开会有所帮助，因为计算的数量将大大减少，但显然例程的准确性也会有所降低。。
艰难的决定。
页:
[1]
2